1# defs.tcl -- 2# 3# This file contains support code for the Tcl/Tk test suite.It is 4# It is normally sourced by the individual files in the test suite 5# before they run their tests. This improved approach to testing 6# was designed and initially implemented by Mary Ann May-Pumphrey 7# of Sun Microsystems. 8# 9# Copyright (c) 1990-1994 The Regents of the University of California. 10# Copyright (c) 1994-1996 Sun Microsystems, Inc. 11# Copyright (c) 1998-1999 by Scriptics Corporation. 12# All rights reserved. 13# 14# RCS: @(#) $Id: defs.tcl,v 1.1 2002/03/25 13:56:21 rolf Exp $ 15 16# Initialize wish shell 17 18if {[info exists tk_version]} { 19 tk appname tktest 20 wm title . tktest 21} else { 22 23 # Ensure that we have a minimal auto_path so we don't pick up extra junk. 24 25 set auto_path [list [info library]] 26} 27 28# create the "tcltest" namespace for all testing variables and procedures 29 30namespace eval tcltest { 31 set procList [list test cleanupTests dotests saveState restoreState \ 32 normalizeMsg makeFile removeFile makeDirectory removeDirectory \ 33 viewFile bytestring set_iso8859_1_locale restore_locale \ 34 safeFetch threadReap] 35 if {[info exists tk_version]} { 36 lappend procList setupbg dobg bgReady cleanupbg fixfocus 37 } 38 foreach proc $procList { 39 namespace export $proc 40 } 41 42 # ::tcltest::verbose defaults to "b" 43 44 variable verbose "b" 45 46 # match defaults to the empty list 47 48 variable match {} 49 50 # skip defaults to the empty list 51 52 variable skip {} 53 54 # Tests should not rely on the current working directory. 55 # Files that are part of the test suite should be accessed relative to 56 # ::tcltest::testsDir. 57 58 set originalDir [pwd] 59 set tDir [file join $originalDir [file dirname [info script]]] 60 cd $tDir 61 variable testsDir [pwd] 62 cd $originalDir 63 64 # Count the number of files tested (0 if all.tcl wasn't called). 65 # The all.tcl file will set testSingleFile to false, so stats will 66 # not be printed until all.tcl calls the cleanupTests proc. 67 # The currentFailure var stores the boolean value of whether the 68 # current test file has had any failures. The failFiles list 69 # stores the names of test files that had failures. 70 71 variable numTestFiles 0 72 variable testSingleFile true 73 variable currentFailure false 74 variable failFiles {} 75 76 # Tests should remove all files they create. The test suite will 77 # check the current working dir for files created by the tests. 78 # ::tcltest::filesMade keeps track of such files created using the 79 # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. 80 # ::tcltest::filesExisted stores the names of pre-existing files. 81 82 variable filesMade {} 83 variable filesExisted {} 84 85 # ::tcltest::numTests will store test files as indices and the list 86 # of files (that should not have been) left behind by the test files. 87 88 array set ::tcltest::createdNewFiles {} 89 90 # initialize ::tcltest::numTests array to keep track fo the number of 91 # tests that pass, fial, and are skipped. 92 93 array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0] 94 95 # initialize ::tcltest::skippedBecause array to keep track of 96 # constraints that kept tests from running 97 98 array set ::tcltest::skippedBecause {} 99 100 # tests that use thread need to know which is the main thread 101 102 variable ::tcltest::mainThread 1 103 if {[info commands testthread] != {}} { 104 set ::tcltest::mainThread [testthread names] 105 } 106} 107 108# If there is no "memory" command (because memory debugging isn't 109# enabled), generate a dummy command that does nothing. 110 111if {[info commands memory] == ""} { 112 proc memory args {} 113} 114 115# ::tcltest::initConfig -- 116# 117# Check configuration information that will determine which tests 118# to run. To do this, create an array ::tcltest::testConfig. Each 119# element has a 0 or 1 value. If the element is "true" then tests 120# with that constraint will be run, otherwise tests with that constraint 121# will be skipped. See the README file for the list of built-in 122# constraints defined in this procedure. 123# 124# Arguments: 125# none 126# 127# Results: 128# The ::tcltest::testConfig array is reset to have an index for 129# each built-in test constraint. 130 131proc ::tcltest::initConfig {} { 132 133 global tcl_platform tcl_interactive tk_version 134 135 catch {unset ::tcltest::testConfig} 136 137 # The following trace procedure makes it so that we can safely refer to 138 # non-existent members of the ::tcltest::testConfig array without causing an 139 # error. Instead, reading a non-existent member will return 0. This is 140 # necessary because tests are allowed to use constraint "X" without ensuring 141 # that ::tcltest::testConfig("X") is defined. 142 143 trace variable ::tcltest::testConfig r ::tcltest::safeFetch 144 145 proc ::tcltest::safeFetch {n1 n2 op} { 146 if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} { 147 set ::tcltest::testConfig($n2) 0 148 } 149 } 150 151 set ::tcltest::testConfig(unixOnly) \ 152 [expr {$tcl_platform(platform) == "unix"}] 153 set ::tcltest::testConfig(macOnly) \ 154 [expr {$tcl_platform(platform) == "macintosh"}] 155 set ::tcltest::testConfig(pcOnly) \ 156 [expr {$tcl_platform(platform) == "windows"}] 157 158 set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly) 159 set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly) 160 set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly) 161 162 set ::tcltest::testConfig(unixOrPc) \ 163 [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}] 164 set ::tcltest::testConfig(macOrPc) \ 165 [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}] 166 set ::tcltest::testConfig(macOrUnix) \ 167 [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}] 168 169 set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] 170 set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] 171 172 # The following config switches are used to mark tests that should work, 173 # but have been temporarily disabled on certain platforms because they don't 174 # and we haven't gotten around to fixing the underlying problem. 175 176 set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}] 177 set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}] 178 set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}] 179 180 # The following config switches are used to mark tests that crash on 181 # certain platforms, so that they can be reactivated again when the 182 # underlying problem is fixed. 183 184 set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}] 185 set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}] 186 set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}] 187 188 # Set the "fonts" constraint for wish apps 189 190 if {[info exists tk_version]} { 191 set ::tcltest::testConfig(fonts) 1 192 catch {destroy .e} 193 entry .e -width 0 -font {Helvetica -12} -bd 1 194 .e insert end "a.bcd" 195 if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { 196 set ::tcltest::testConfig(fonts) 0 197 } 198 destroy .e 199 catch {destroy .t} 200 text .t -width 80 -height 20 -font {Times -14} -bd 1 201 pack .t 202 .t insert end "This is\na dot." 203 update 204 set x [list [.t bbox 1.3] [.t bbox 2.5]] 205 destroy .t 206 if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} { 207 set ::tcltest::testConfig(fonts) 0 208 } 209 } 210 211 # Skip empty tests 212 213 set ::tcltest::testConfig(emptyTest) 0 214 215 # By default, tests that expost known bugs are skipped. 216 217 set ::tcltest::testConfig(knownBug) 0 218 219 # By default, non-portable tests are skipped. 220 221 set ::tcltest::testConfig(nonPortable) 0 222 223 # Some tests require user interaction. 224 225 set ::tcltest::testConfig(userInteraction) 0 226 227 # Some tests must be skipped if the interpreter is not in interactive mode 228 229 set ::tcltest::testConfig(interactive) $tcl_interactive 230 231 # Some tests must be skipped if you are running as root on Unix. 232 # Other tests can only be run if you are running as root on Unix. 233 234 set ::tcltest::testConfig(root) 0 235 set ::tcltest::testConfig(notRoot) 1 236 set user {} 237 if {$tcl_platform(platform) == "unix"} { 238 catch {set user [exec whoami]} 239 if {$user == ""} { 240 catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} 241 } 242 if {($user == "root") || ($user == "")} { 243 set ::tcltest::testConfig(root) 1 244 set ::tcltest::testConfig(notRoot) 0 245 } 246 } 247 248 # Set nonBlockFiles constraint: 1 means this platform supports 249 # setting files into nonblocking mode. 250 251 if {[catch {set f [open defs r]}]} { 252 set ::tcltest::testConfig(nonBlockFiles) 1 253 } else { 254 if {[catch {fconfigure $f -blocking off}] == 0} { 255 set ::tcltest::testConfig(nonBlockFiles) 1 256 } else { 257 set ::tcltest::testConfig(nonBlockFiles) 0 258 } 259 close $f 260 } 261 262 # Set asyncPipeClose constraint: 1 means this platform supports 263 # async flush and async close on a pipe. 264 # 265 # Test for SCO Unix - cannot run async flushing tests because a 266 # potential problem with select is apparently interfering. 267 # (Mark Diekhans). 268 269 if {$tcl_platform(platform) == "unix"} { 270 if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { 271 set ::tcltest::testConfig(asyncPipeClose) 0 272 } else { 273 set ::tcltest::testConfig(asyncPipeClose) 1 274 } 275 } else { 276 set ::tcltest::testConfig(asyncPipeClose) 1 277 } 278 279 # Test to see if we have a broken version of sprintf with respect 280 # to the "e" format of floating-point numbers. 281 282 set ::tcltest::testConfig(eformat) 1 283 if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { 284 set ::tcltest::testConfig(eformat) 0 285 } 286 287 # Test to see if execed commands such as cat, echo, rm and so forth are 288 # present on this machine. 289 290 set ::tcltest::testConfig(unixExecs) 1 291 if {$tcl_platform(platform) == "macintosh"} { 292 set ::tcltest::testConfig(unixExecs) 0 293 } 294 if {($::tcltest::testConfig(unixExecs) == 1) && \ 295 ($tcl_platform(platform) == "windows")} { 296 if {[catch {exec cat defs}] == 1} { 297 set ::tcltest::testConfig(unixExecs) 0 298 } 299 if {($::tcltest::testConfig(unixExecs) == 1) && \ 300 ([catch {exec echo hello}] == 1)} { 301 set ::tcltest::testConfig(unixExecs) 0 302 } 303 if {($::tcltest::testConfig(unixExecs) == 1) && \ 304 ([catch {exec sh -c echo hello}] == 1)} { 305 set ::tcltest::testConfig(unixExecs) 0 306 } 307 if {($::tcltest::testConfig(unixExecs) == 1) && \ 308 ([catch {exec wc defs}] == 1)} { 309 set ::tcltest::testConfig(unixExecs) 0 310 } 311 if {$::tcltest::testConfig(unixExecs) == 1} { 312 exec echo hello > removeMe 313 if {[catch {exec rm removeMe}] == 1} { 314 set ::tcltest::testConfig(unixExecs) 0 315 } 316 } 317 if {($::tcltest::testConfig(unixExecs) == 1) && \ 318 ([catch {exec sleep 1}] == 1)} { 319 set ::tcltest::testConfig(unixExecs) 0 320 } 321 if {($::tcltest::testConfig(unixExecs) == 1) && \ 322 ([catch {exec fgrep unixExecs defs}] == 1)} { 323 set ::tcltest::testConfig(unixExecs) 0 324 } 325 if {($::tcltest::testConfig(unixExecs) == 1) && \ 326 ([catch {exec ps}] == 1)} { 327 set ::tcltest::testConfig(unixExecs) 0 328 } 329 if {($::tcltest::testConfig(unixExecs) == 1) && \ 330 ([catch {exec echo abc > removeMe}] == 0) && \ 331 ([catch {exec chmod 644 removeMe}] == 1) && \ 332 ([catch {exec rm removeMe}] == 0)} { 333 set ::tcltest::testConfig(unixExecs) 0 334 } else { 335 catch {exec rm -f removeMe} 336 } 337 if {($::tcltest::testConfig(unixExecs) == 1) && \ 338 ([catch {exec mkdir removeMe}] == 1)} { 339 set ::tcltest::testConfig(unixExecs) 0 340 } else { 341 catch {exec rm -r removeMe} 342 } 343 } 344} 345 346::tcltest::initConfig 347 348 349# ::tcltest::processCmdLineArgs -- 350# 351# Use command line args to set the verbose, skip, and 352# match variables. This procedure must be run after 353# constraints are initialized, because some constraints can be 354# overridden. 355# 356# Arguments: 357# none 358# 359# Results: 360# ::tcltest::verbose is set to <value> 361 362proc ::tcltest::processCmdLineArgs {} { 363 global argv 364 365 # The "argv" var doesn't exist in some cases, so use {} 366 # The "argv" var doesn't exist in some cases. 367 368 if {(![info exists argv]) || ([llength $argv] < 2)} { 369 set flagArray {} 370 } else { 371 set flagArray $argv 372 } 373 374 if {[catch {array set flag $flagArray}]} { 375 puts stderr "Error: odd number of command line args specified:" 376 puts stderr " $argv" 377 exit 378 } 379 380 # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). 381 # Note that -verbose cannot be abbreviated to -v in wish because it 382 # conflicts with the wish option -visual. 383 384 foreach arg {-verbose -match -skip -constraints} { 385 set abbrev [string range $arg 0 1] 386 if {([info exists flag($abbrev)]) && \ 387 ([lsearch -exact $flagArray $arg] < \ 388 [lsearch -exact $flagArray $abbrev])} { 389 set flag($arg) $flag($abbrev) 390 } 391 } 392 393 # Set ::tcltest::workingDir to [pwd]. 394 # Save the names of files that already exist in ::tcltest::workingDir. 395 396 set ::tcltest::workingDir [pwd] 397 foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] { 398 lappend ::tcltest::filesExisted [file tail $file] 399 } 400 401 # Set ::tcltest::verbose to the arg of the -verbose flag, if given 402 403 if {[info exists flag(-verbose)]} { 404 set ::tcltest::verbose $flag(-verbose) 405 } 406 407 # Set ::tcltest::match to the arg of the -match flag, if given 408 409 if {[info exists flag(-match)]} { 410 set ::tcltest::match $flag(-match) 411 } 412 413 # Set ::tcltest::skip to the arg of the -skip flag, if given 414 415 if {[info exists flag(-skip)]} { 416 set ::tcltest::skip $flag(-skip) 417 } 418 419 # Use the -constraints flag, if given, to turn on constraints that are 420 # turned off by default: userInteractive knownBug nonPortable. This 421 # code fragment must be run after constraints are initialized. 422 423 if {[info exists flag(-constraints)]} { 424 foreach elt $flag(-constraints) { 425 set ::tcltest::testConfig($elt) 1 426 } 427 } 428} 429 430::tcltest::processCmdLineArgs 431 432 433# ::tcltest::cleanupTests -- 434# 435# Remove files and dirs created using the makeFile and makeDirectory 436# commands since the last time this proc was invoked. 437# 438# Print the names of the files created without the makeFile command 439# since the tests were invoked. 440# 441# Print the number tests (total, passed, failed, and skipped) since the 442# tests were invoked. 443# 444 445proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { 446 set tail [file tail [info script]] 447 448 # Remove files and directories created by the :tcltest::makeFile and 449 # ::tcltest::makeDirectory procedures. 450 # Record the names of files in ::tcltest::workingDir that were not 451 # pre-existing, and associate them with the test file that created them. 452 453 if {!$calledFromAllFile} { 454 455 foreach file $::tcltest::filesMade { 456 if {[file exists $file]} { 457 catch {file delete -force $file} 458 } 459 } 460 set currentFiles {} 461 foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] { 462 lappend currentFiles [file tail $file] 463 } 464 set newFiles {} 465 foreach file $currentFiles { 466 if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { 467 lappend newFiles $file 468 } 469 } 470 set ::tcltest::filesExisted $currentFiles 471 if {[llength $newFiles] > 0} { 472 set ::tcltest::createdNewFiles($tail) $newFiles 473 } 474 } 475 476 if {$calledFromAllFile || $::tcltest::testSingleFile} { 477 478 # print stats 479 480 puts -nonewline stdout "$tail:" 481 foreach index [list "Total" "Passed" "Skipped" "Failed"] { 482 puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)" 483 } 484 puts stdout "" 485 486 # print number test files sourced 487 # print names of files that ran tests which failed 488 489 if {$calledFromAllFile} { 490 puts stdout "Sourced $::tcltest::numTestFiles Test Files." 491 set ::tcltest::numTestFiles 0 492 if {[llength $::tcltest::failFiles] > 0} { 493 puts stdout "Files with failing tests: $::tcltest::failFiles" 494 set ::tcltest::failFiles {} 495 } 496 } 497 498 # if any tests were skipped, print the constraints that kept them 499 # from running. 500 501 set constraintList [array names ::tcltest::skippedBecause] 502 if {[llength $constraintList] > 0} { 503 puts stdout "Number of tests skipped for each constraint:" 504 foreach constraint [lsort $constraintList] { 505 puts stdout \ 506 "\t$::tcltest::skippedBecause($constraint)\t$constraint" 507 unset ::tcltest::skippedBecause($constraint) 508 } 509 } 510 511 # report the names of test files in ::tcltest::createdNewFiles, and 512 # reset the array to be empty. 513 514 set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] 515 if {[llength $testFilesThatTurded] > 0} { 516 puts stdout "Warning: test files left files behind:" 517 foreach testFile $testFilesThatTurded { 518 puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" 519 unset ::tcltest::createdNewFiles($testFile) 520 } 521 } 522 523 # reset filesMade, filesExisted, and numTests 524 525 set ::tcltest::filesMade {} 526 foreach index [list "Total" "Passed" "Skipped" "Failed"] { 527 set ::tcltest::numTests($index) 0 528 } 529 530 # exit only if running Tk in non-interactive mode 531 532 global tk_version tcl_interactive 533 if {[info exists tk_version] && !$tcl_interactive} { 534 exit 535 } 536 } else { 537 538 # if we're deferring stat-reporting until all files are sourced, 539 # then add current file to failFile list if any tests in this file 540 # failed 541 542 incr ::tcltest::numTestFiles 543 if {($::tcltest::currentFailure) && \ 544 ([lsearch -exact $::tcltest::failFiles $tail] == -1)} { 545 lappend ::tcltest::failFiles $tail 546 } 547 set ::tcltest::currentFailure false 548 } 549} 550 551 552# test -- 553# 554# This procedure runs a test and prints an error message if the test fails. 555# If ::tcltest::verbose has been set, it also prints a message even if the 556# test succeeds. The test will be skipped if it doesn't match the 557# ::tcltest::match variable, if it matches an element in 558# ::tcltest::skip, or if one of the elements of "constraints" turns 559# out not to be true. 560# 561# Arguments: 562# name - Name of test, in the form foo-1.2. 563# description - Short textual description of the test, to 564# help humans understand what it does. 565# constraints - A list of one or more keywords, each of 566# which must be the name of an element in 567# the array "::tcltest::testConfig". If any of these 568# elements is zero, the test is skipped. 569# This argument may be omitted. 570# script - Script to run to carry out the test. It must 571# return a result that can be checked for 572# correctness. 573# expectedAnswer - Expected result from script. 574 575proc ::tcltest::test {name description script expectedAnswer args} { 576 incr ::tcltest::numTests(Total) 577 578 # skip the test if it's name matches an element of skip 579 580 foreach pattern $::tcltest::skip { 581 if {[string match $pattern $name]} { 582 incr ::tcltest::numTests(Skipped) 583 return 584 } 585 } 586 # skip the test if it's name doesn't match any element of match 587 588 if {[llength $::tcltest::match] > 0} { 589 set ok 0 590 foreach pattern $::tcltest::match { 591 if {[string match $pattern $name]} { 592 set ok 1 593 break 594 } 595 } 596 if {!$ok} { 597 incr ::tcltest::numTests(Skipped) 598 return 599 } 600 } 601 set i [llength $args] 602 if {$i == 0} { 603 set constraints {} 604 } elseif {$i == 1} { 605 606 # "constraints" argument exists; shuffle arguments down, then 607 # make sure that the constraints are satisfied. 608 609 set constraints $script 610 set script $expectedAnswer 611 set expectedAnswer [lindex $args 0] 612 set doTest 0 613 if {[string match {*[$\[]*} $constraints] != 0} { 614 615 # full expression, e.g. {$foo > [info tclversion]} 616 617 catch {set doTest [uplevel #0 expr $constraints]} 618 619 } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { 620 621 # something like {a || b} should be turned into 622 # $::tcltest::testConfig(a) || $::tcltest::testConfig(b). 623 624 regsub -all {[.a-zA-Z0-9]+} $constraints \ 625 {$::tcltest::testConfig(&)} c 626 catch {set doTest [eval expr $c]} 627 } else { 628 629 # just simple constraints such as {unixOnly fonts}. 630 631 set doTest 1 632 foreach constraint $constraints { 633 if {![info exists ::tcltest::testConfig($constraint)] 634 || !$::tcltest::testConfig($constraint)} { 635 set doTest 0 636 637 # store the constraint that kept the test from running 638 639 set constraints $constraint 640 break 641 } 642 } 643 } 644 if {$doTest == 0} { 645 incr ::tcltest::numTests(Skipped) 646 if {[string first s $::tcltest::verbose] != -1} { 647 puts stdout "++++ $name SKIPPED: $constraints" 648 } 649 650 # add the constraint to the list of constraints the kept tests 651 # from running 652 653 if {[info exists ::tcltest::skippedBecause($constraints)]} { 654 incr ::tcltest::skippedBecause($constraints) 655 } else { 656 set ::tcltest::skippedBecause($constraints) 1 657 } 658 return 659 } 660 } else { 661 error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" 662 } 663 memory tag $name 664 set code [catch {uplevel $script} actualAnswer] 665 if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} { 666 incr ::tcltest::numTests(Failed) 667 set ::tcltest::currentFailure true 668 if {[string first b $::tcltest::verbose] == -1} { 669 set script "" 670 } 671 puts stdout "\n==== $name $description FAILED" 672 if {$script != ""} { 673 puts stdout "==== Contents of test case:" 674 puts stdout $script 675 } 676 if {$code != 0} { 677 if {$code == 1} { 678 puts stdout "==== Test generated error:" 679 puts stdout $actualAnswer 680 } elseif {$code == 2} { 681 puts stdout "==== Test generated return exception; result was:" 682 puts stdout $actualAnswer 683 } elseif {$code == 3} { 684 puts stdout "==== Test generated break exception" 685 } elseif {$code == 4} { 686 puts stdout "==== Test generated continue exception" 687 } else { 688 puts stdout "==== Test generated exception $code; message was:" 689 puts stdout $actualAnswer 690 } 691 } else { 692 puts stdout "---- Result was:\n$actualAnswer" 693 } 694 puts stdout "---- Result should have been:\n$expectedAnswer" 695 puts stdout "==== $name FAILED\n" 696 } else { 697 incr ::tcltest::numTests(Passed) 698 if {[string first p $::tcltest::verbose] != -1} { 699 puts stdout "++++ $name PASSED" 700 } 701 } 702} 703 704# ::tcltest::dotests -- 705# 706# takes two arguments--the name of the test file (such 707# as "parse.test"), and a pattern selecting the tests you want to 708# execute. It sets ::tcltest::matching to the second argument, calls 709# "source" on the file specified in the first argument, and restores 710# ::tcltest::matching to its pre-call value at the end. 711# 712# Arguments: 713# file name of tests file to source 714# args pattern selecting the tests you want to execute 715# 716# Results: 717# none 718 719proc ::tcltest::dotests {file args} { 720 set savedTests $::tcltest::match 721 set ::tcltest::match $args 722 source $file 723 set ::tcltest::match $savedTests 724} 725 726proc ::tcltest::openfiles {} { 727 if {[catch {testchannel open} result]} { 728 return {} 729 } 730 return $result 731} 732 733proc ::tcltest::leakfiles {old} { 734 if {[catch {testchannel open} new]} { 735 return {} 736 } 737 set leak {} 738 foreach p $new { 739 if {[lsearch $old $p] < 0} { 740 lappend leak $p 741 } 742 } 743 return $leak 744} 745 746set ::tcltest::saveState {} 747 748proc ::tcltest::saveState {} { 749 uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} 750} 751 752proc ::tcltest::restoreState {} { 753 foreach p [info procs] { 754 if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} { 755 rename $p {} 756 } 757 } 758 foreach p [uplevel #0 {info vars}] { 759 if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { 760 uplevel #0 "unset $p" 761 } 762 } 763} 764 765proc ::tcltest::normalizeMsg {msg} { 766 regsub "\n$" [string tolower $msg] "" msg 767 regsub -all "\n\n" $msg "\n" msg 768 regsub -all "\n\}" $msg "\}" msg 769 return $msg 770} 771 772# makeFile -- 773# 774# Create a new file with the name <name>, and write <contents> to it. 775# 776# If this file hasn't been created via makeFile since the last time 777# cleanupTests was called, add it to the $filesMade list, so it will 778# be removed by the next call to cleanupTests. 779# 780proc ::tcltest::makeFile {contents name} { 781 set fd [open $name w] 782 fconfigure $fd -translation lf 783 if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} { 784 puts -nonewline $fd $contents 785 } else { 786 puts $fd $contents 787 } 788 close $fd 789 790 set fullName [file join [pwd] $name] 791 if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { 792 lappend ::tcltest::filesMade $fullName 793 } 794} 795 796proc ::tcltest::removeFile {name} { 797 file delete $name 798} 799 800# makeDirectory -- 801# 802# Create a new dir with the name <name>. 803# 804# If this dir hasn't been created via makeDirectory since the last time 805# cleanupTests was called, add it to the $directoriesMade list, so it will 806# be removed by the next call to cleanupTests. 807# 808proc ::tcltest::makeDirectory {name} { 809 file mkdir $name 810 811 set fullName [file join [pwd] $name] 812 if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { 813 lappend ::tcltest::filesMade $fullName 814 } 815} 816 817proc ::tcltest::removeDirectory {name} { 818 file delete -force $name 819} 820 821proc ::tcltest::viewFile {name} { 822 global tcl_platform 823 if {($tcl_platform(platform) == "macintosh") || \ 824 ($::tcltest::testConfig(unixExecs) == 0)} { 825 set f [open $name] 826 set data [read -nonewline $f] 827 close $f 828 return $data 829 } else { 830 exec cat $name 831 } 832} 833 834# 835# Construct a string that consists of the requested sequence of bytes, 836# as opposed to a string of properly formed UTF-8 characters. 837# This allows the tester to 838# 1. Create denormalized or improperly formed strings to pass to C procedures 839# that are supposed to accept strings with embedded NULL bytes. 840# 2. Confirm that a string result has a certain pattern of bytes, for instance 841# to confirm that "\xe0\0" in a Tcl script is stored internally in 842# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". 843# 844# Generally, it's a bad idea to examine the bytes in a Tcl string or to 845# construct improperly formed strings in this manner, because it involves 846# exposing that Tcl uses UTF-8 internally. 847 848proc ::tcltest::bytestring {string} { 849 encoding convertfrom identity $string 850} 851 852# Locate tcltest executable 853 854if {![info exists tk_version]} { 855 set tcltest [info nameofexecutable] 856 857 if {$tcltest == "{}"} { 858 set tcltest {} 859 } 860} 861 862set ::tcltest::testConfig(stdio) 0 863catch { 864 catch {file delete -force tmp} 865 set f [open tmp w] 866 puts $f { 867 exit 868 } 869 close $f 870 871 set f [open "|[list $tcltest tmp]" r] 872 close $f 873 874 set ::tcltest::testConfig(stdio) 1 875} 876catch {file delete -force tmp} 877 878# Deliberately call the socket with the wrong number of arguments. The error 879# message you get will indicate whether sockets are available on this system. 880 881catch {socket} msg 882set ::tcltest::testConfig(socket) \ 883 [expr {$msg != "sockets are not available on this system"}] 884 885# 886# Internationalization / ISO support procs -- dl 887# 888 889if {[info commands testlocale]==""} { 890 891 # No testlocale command, no tests... 892 # (it could be that we are a sub interp and we could just load 893 # the Tcltest package but that would interfere with tests 894 # that tests packages/loading in slaves...) 895 896 set ::tcltest::testConfig(hasIsoLocale) 0 897} else { 898 proc ::tcltest::set_iso8859_1_locale {} { 899 set ::tcltest::previousLocale [testlocale ctype] 900 testlocale ctype $::tcltest::isoLocale 901 } 902 903 proc ::tcltest::restore_locale {} { 904 testlocale ctype $::tcltest::previousLocale 905 } 906 907 if {![info exists ::tcltest::isoLocale]} { 908 set ::tcltest::isoLocale fr 909 switch $tcl_platform(platform) { 910 "unix" { 911 912 # Try some 'known' values for some platforms: 913 914 switch -exact -- $tcl_platform(os) { 915 "FreeBSD" { 916 set ::tcltest::isoLocale fr_FR.ISO_8859-1 917 } 918 HP-UX { 919 set ::tcltest::isoLocale fr_FR.iso88591 920 } 921 Linux - 922 IRIX { 923 set ::tcltest::isoLocale fr 924 } 925 default { 926 927 # Works on SunOS 4 and Solaris, and maybe others... 928 # define it to something else on your system 929 #if you want to test those. 930 931 set ::tcltest::isoLocale iso_8859_1 932 } 933 } 934 } 935 "windows" { 936 set ::tcltest::isoLocale French 937 } 938 } 939 } 940 941 set ::tcltest::testConfig(hasIsoLocale) \ 942 [string length [::tcltest::set_iso8859_1_locale]] 943 ::tcltest::restore_locale 944} 945 946# 947# procedures that are Tk specific 948# 949 950if {[info exists tk_version]} { 951 952 # If the main window isn't already mapped (e.g. because the tests are 953 # being run automatically) , specify a precise size for it so that the 954 # user won't have to position it manually. 955 956 if {![winfo ismapped .]} { 957 wm geometry . +0+0 958 update 959 } 960 961 # The following code can be used to perform tests involving a second 962 # process running in the background. 963 964 # Locate the tktest executable 965 966 set ::tcltest::tktest [info nameofexecutable] 967 if {$::tcltest::tktest == "{}"} { 968 set ::tcltest::tktest {} 969 puts stdout \ 970 "Unable to find tktest executable, skipping multiple process tests." 971 } 972 973 # Create background process 974 975 proc ::tcltest::setupbg args { 976 if {$::tcltest::tktest == ""} { 977 error "you're not running tktest so setupbg should not have been called" 978 } 979 if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} { 980 cleanupbg 981 } 982 983 # The following code segment cannot be run on Windows in Tk8.1b2 984 # This bug is logged as a pipe bug (bugID 1495). 985 986 global tcl_platform 987 if {$tcl_platform(platform) != "windows"} { 988 set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+] 989 puts $::tcltest::fd "puts foo; flush stdout" 990 flush $::tcltest::fd 991 if {[gets $::tcltest::fd data] < 0} { 992 error "unexpected EOF from \"$::tcltest::tktest\"" 993 } 994 if {[string compare $data foo]} { 995 error "unexpected output from background process \"$data\"" 996 } 997 fileevent $::tcltest::fd readable bgReady 998 } 999 } 1000 1001 # Send a command to the background process, catching errors and 1002 # flushing I/O channels 1003 1004 proc ::tcltest::dobg {command} { 1005 puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout" 1006 flush $::tcltest::fd 1007 set ::tcltest::bgDone 0 1008 set ::tcltest::bgData {} 1009 tkwait variable ::tcltest::bgDone 1010 set ::tcltest::bgData 1011 } 1012 1013 # Data arrived from background process. Check for special marker 1014 # indicating end of data for this command, and make data available 1015 # to dobg procedure. 1016 1017 proc ::tcltest::bgReady {} { 1018 set x [gets $::tcltest::fd] 1019 if {[eof $::tcltest::fd]} { 1020 fileevent $::tcltest::fd readable {} 1021 set ::tcltest::bgDone 1 1022 } elseif {$x == "**DONE**"} { 1023 set ::tcltest::bgDone 1 1024 } else { 1025 append ::tcltest::bgData $x 1026 } 1027 } 1028 1029 # Exit the background process, and close the pipes 1030 1031 proc ::tcltest::cleanupbg {} { 1032 catch { 1033 puts $::tcltest::fd "exit" 1034 close $::tcltest::fd 1035 } 1036 set ::tcltest::fd "" 1037 } 1038 1039 # Clean up focus after using generate event, which 1040 # can leave the window manager with the wrong impression 1041 # about who thinks they have the focus. (BW) 1042 1043 proc ::tcltest::fixfocus {} { 1044 catch {destroy .focus} 1045 toplevel .focus 1046 wm geometry .focus +0+0 1047 entry .focus.e 1048 .focus.e insert 0 "fixfocus" 1049 pack .focus.e 1050 update 1051 focus -force .focus.e 1052 destroy .focus 1053 } 1054} 1055 1056# threadReap -- 1057# 1058# Kill all threads except for the main thread. 1059# Do nothing if testthread is not defined. 1060# 1061# Arguments: 1062# none. 1063# 1064# Results: 1065# Returns the number of existing threads. 1066 1067if {[info commands testthread] != {}} { 1068 proc ::tcltest::threadReap {} { 1069 testthread errorproc ThreadNullError 1070 while {[llength [testthread names]] > 1} { 1071 foreach tid [testthread names] { 1072 if {$tid != $::tcltest::mainThread} { 1073 catch {testthread send -async $tid {testthread exit}} 1074 update 1075 } 1076 } 1077 } 1078 testthread errorproc ThreadError 1079 return [llength [testthread names]] 1080 } 1081} else { 1082 proc ::tcltest::threadReap {} { 1083 return 1 1084 } 1085} 1086 1087# Need to catch the import because it fails if defs.tcl is sourced 1088# more than once. 1089 1090catch {namespace import ::tcltest::*} 1091return 1092