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