1# -*- tcl -*- 2# Testsuite utilities / boilerplate 3# Copyright (c) 2006, Andreas Kupries <andreas_kupries@users.sourceforge.net> 4 5namespace eval ::tcllib::testutils { 6 variable version 1.2 7 variable self [file dirname [file join [pwd] [info script]]] 8 variable tcllib [file dirname $self] 9 variable tag "" 10 variable theEnv ; # Saved environment. 11} 12 13# ### ### ### ######### ######### ######### 14## Commands for common functions and boilerplate actions required by 15## many testsuites of Tcllib modules and packages in a central place 16## for easier maintenance. 17 18# ### ### ### ######### ######### ######### 19## Declare the minimal version of Tcl required to run the package 20## tested by this testsuite, and its dependencies. 21 22proc testsNeedTcl {version} { 23 # This command ensures that a minimum version of Tcl is used to 24 # run the tests in the calling testsuite. If the minimum is not 25 # met by the active interpreter we forcibly bail out of the 26 # testsuite calling the command. The command has to be called 27 # immediately after loading the utilities. 28 29 if {[package vsatisfies [package provide Tcl] $version]} return 30 31 puts " Aborting the tests found in \"[file tail [info script]]\"" 32 puts " Requiring at least Tcl $version, have [package present Tcl]." 33 34 # This causes a 'return' in the calling scope. 35 return -code return 36} 37 38# ### ### ### ######### ######### ######### 39## Declare the minimum version of Tcltest required to run the 40## testsuite. 41 42proc testsNeedTcltest {version} { 43 # This command ensure that a minimum version of the Tcltest 44 # support package is used to run the tests in the calling 45 # testsuite. If the minimum is not met by the loaded package we 46 # forcibly bail out of the testsuite calling the command. The 47 # command has to be called after loading the utilities. The only 48 # command allowed to come before it is 'textNeedTcl' above. 49 50 # Note that this command will try to load a suitable version of 51 # Tcltest if the package has not been loaded yet. 52 53 if {[lsearch [namespace children] ::tcltest] == -1} { 54 if {![catch { 55 package require tcltest $version 56 }]} { 57 namespace import -force ::tcltest::* 58 return 59 } 60 } elseif {[package vcompare [package present tcltest] $version] >= 0} { 61 return 62 } 63 64 puts " Aborting the tests found in [file tail [info script]]." 65 puts " Requiring at least tcltest $version, have [package present tcltest]" 66 67 # This causes a 'return' in the calling scope. 68 return -code return 69} 70 71proc testsNeed {name version} { 72 # This command ensures that a minimum version of package <name> is 73 # used to run the tests in the calling testsuite. If the minimum 74 # is not met by the active interpreter we forcibly bail out of the 75 # testsuite calling the command. The command has to be called 76 # immediately after loading the utilities. 77 78 if {[package vsatisfies [package provide $name] $version]} return 79 80 puts " Aborting the tests found in \"[file tail [info script]]\"" 81 puts " Requiring at least $name $version, have [package present $name]." 82 83 # This causes a 'return' in the calling scope. 84 return -code return 85} 86 87# ### ### ### ######### ######### ######### 88 89## Save/restore the environment, for testsuites which have to 90## manipulate it to (1) either achieve the effects they test 91## for/against, or (2) to shield themselves against manipulation by 92## the environment. We have examples for both in 'fileutil' (1), and 93## 'doctools' (2). 94## 95## Saving is done automatically at the beginning of a test file, 96## through this module. Restoration is done semi-automatically. We 97## __cannot__ hook into the tcltest cleanup hook It is already used by 98## all.tcl to transfer the information from the slave doing the actual 99## tests to the master. Here the hook is only an alias, and 100## unmodifiable. We create a new cleanup command which runs both our 101## environment cleanup, and the regular one. All .test files are 102## modified to use the new cleanup. 103 104proc ::tcllib::testutils::SaveEnvironment {} { 105 global env 106 variable theEnv [array get env] 107 return 108} 109 110proc ::tcllib::testutils::RestoreEnvironment {} { 111 global env 112 variable theEnv 113 foreach k [array names env] { 114 unset env($k) 115 } 116 array set env $theEnv 117 return 118} 119 120proc testsuiteCleanup {} { 121 ::tcllib::testutils::RestoreEnvironment 122 ::tcltest::cleanupTests 123 return 124} 125 126proc array_unset {a {pattern *}} { 127 upvar 1 $a array 128 foreach k [array names array $pattern] { 129 unset array($k) 130 } 131 return 132} 133 134# ### ### ### ######### ######### ######### 135## Newer versions of the Tcltest support package for testsuite provide 136## various features which make the creation and maintenance of 137## testsuites much easier. I consider it important to have these 138## features even if an older version of Tcltest is loaded. To this end 139## we now provide emulations and implementations, conditional on the 140## version of Tcltest found to be active. 141 142# ### ### ### ######### ######### ######### 143## Easy definition and initialization of test constraints. 144 145if {![package vsatisfies [package provide tcltest] 2.0]} { 146 # Tcltest 2.0+ provides a documented public API to define and 147 # initialize a test constraint. For earlier versions of the 148 # package the user has to directly set a non-public undocumented 149 # variable in the package's namespace. We create a command doing 150 # this and emulating the public API. 151 152 proc ::tcltest::testConstraint {c args} { 153 variable testConstraints 154 if {[llength $args] < 1} { 155 if {[info exists testConstraints($c)]} { 156 return $testConstraints($c) 157 } else { 158 return {} 159 } 160 } else { 161 set testConstraints($c) [lindex $args 0] 162 } 163 return 164 } 165 166 namespace eval ::tcltest { 167 namespace export testConstraint 168 } 169 namespace import -force ::tcltest::* 170} 171 172# ### ### ### ######### ######### ######### 173## Define a set of standard constraints 174 175::tcltest::testConstraint tcl8.3only \ 176 [expr {![package vsatisfies [package provide Tcl] 8.4]}] 177 178::tcltest::testConstraint tcl8.3plus \ 179 [expr {[package vsatisfies [package provide Tcl] 8.3]}] 180 181::tcltest::testConstraint tcl8.4plus \ 182 [expr {[package vsatisfies [package provide Tcl] 8.4]}] 183 184::tcltest::testConstraint tcl8.5plus \ 185 [expr {[package vsatisfies [package provide Tcl] 8.5]}] 186 187::tcltest::testConstraint tcl8.6plus \ 188 [expr {[package vsatisfies [package provide Tcl] 8.6]}] 189 190::tcltest::testConstraint tcl8.4minus \ 191 [expr {![package vsatisfies [package provide Tcl] 8.5]}] 192 193# ### ### ### ######### ######### ######### 194## Cross-version code for the generation of the error messages created 195## by Tcl procedures when called with the wrong number of arguments, 196## either too many, or not enough. 197 198if {[package vsatisfies [package provide Tcl] 8.6]} { 199 # 8.6+ 200 proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { 201 if {[string match args [lindex $argList end]]} { 202 set argList [lreplace $argList end end ?arg ...?] 203 } 204 if {$argList != {}} {set argList " $argList"} 205 set msg "wrong # args: should be \"$functionName$argList\"" 206 return $msg 207 } 208 209 proc ::tcltest::tooManyArgs {functionName argList} { 210 # create a different message for functions with no args 211 if {[llength $argList]} { 212 if {[string match args [lindex $argList end]]} { 213 set argList [lreplace $argList end end ?arg ...?] 214 } 215 set msg "wrong # args: should be \"$functionName $argList\"" 216 } else { 217 set msg "wrong # args: should be \"$functionName\"" 218 } 219 return $msg 220 } 221} elseif {[package vsatisfies [package provide Tcl] 8.5]} { 222 # 8.5 223 proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { 224 if {[string match args [lindex $argList end]]} { 225 set argList [lreplace $argList end end ...] 226 } 227 if {$argList != {}} {set argList " $argList"} 228 set msg "wrong # args: should be \"$functionName$argList\"" 229 return $msg 230 } 231 232 proc ::tcltest::tooManyArgs {functionName argList} { 233 # create a different message for functions with no args 234 if {[llength $argList]} { 235 if {[string match args [lindex $argList end]]} { 236 set argList [lreplace $argList end end ...] 237 } 238 set msg "wrong # args: should be \"$functionName $argList\"" 239 } else { 240 set msg "wrong # args: should be \"$functionName\"" 241 } 242 return $msg 243 } 244} elseif {[package vsatisfies [package provide Tcl] 8.4]} { 245 # 8.4+ 246 proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { 247 if {$argList != {}} {set argList " $argList"} 248 set msg "wrong # args: should be \"$functionName$argList\"" 249 return $msg 250 } 251 252 proc ::tcltest::tooManyArgs {functionName argList} { 253 # create a different message for functions with no args 254 if {[llength $argList]} { 255 set msg "wrong # args: should be \"$functionName $argList\"" 256 } else { 257 set msg "wrong # args: should be \"$functionName\"" 258 } 259 return $msg 260 } 261} else { 262 # 8.2+ 263 proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { 264 set msg "no value given for parameter " 265 append msg "\"[lindex $argList $missingIndex]\" to " 266 append msg "\"$functionName\"" 267 return $msg 268 } 269 270 proc ::tcltest::tooManyArgs {functionName argList} { 271 set msg "called \"$functionName\" with too many arguments" 272 return $msg 273 } 274} 275 276namespace eval ::tcltest { 277 namespace export wrongNumArgs tooManyArgs 278} 279namespace import -force ::tcltest::* 280 281# ### ### ### ######### ######### ######### 282## Command to construct wrong/args messages for Snit methods. 283 284proc snitErrors {} { 285 if {[package vsatisfies [package provide snit] 2]} { 286 # Snit 2.0+ 287 288 proc snitWrongNumArgs {obj method arglist missingIndex} { 289 regsub {^.*Snit_method} $method {} method 290 tcltest::wrongNumArgs "$obj $method" $arglist $missingIndex 291 } 292 293 proc snitTooManyArgs {obj method arglist} { 294 regsub {^.*Snit_method} $method {} method 295 tcltest::tooManyArgs "$obj $method" $arglist 296 } 297 298 } else { 299 proc snitWrongNumArgs {obj method arglist missingIndex} { 300 incr missingIndex 4 301 tcltest::wrongNumArgs "$obj $method" [linsert $arglist 0 \ 302 type selfns win self] $missingIndex 303 } 304 305 proc snitTooManyArgs {obj method arglist} { 306 tcltest::tooManyArgs "$obj $method" [linsert $arglist 0 \ 307 type selfns win self] 308 } 309 } 310} 311 312# ### ### ### ######### ######### ######### 313## tclTest::makeFile result API changed for 2.0 314 315if {![package vsatisfies [package provide tcltest] 2.0]} { 316 317 # The 'makeFile' in Tcltest 1.0 returns a list of all the paths 318 # generated so far, whereas the 'makeFile' in 2.0+ returns only 319 # the path of the newly generated file. We standardize on the more 320 # useful behaviour of 2.0+. If 1.x is present we have to create an 321 # emulation layer to get the wanted result. 322 323 # 1.0 is not fully correctly described. If the file was created 324 # before no list is returned at all. We force things by adding a 325 # line to the old procedure which makes the result unconditional 326 # (the name of the file/dir created). 327 328 # The same change applies to 'makeDirectory' 329 330 if {![llength [info commands ::tcltest::makeFile_1]]} { 331 # Marker first. 332 proc ::tcltest::makeFile_1 {args} {} 333 334 # Extend procedures with command to return the required full 335 # name. 336 proc ::tcltest::makeFile {contents name} \ 337 [info body ::tcltest::makeFile]\n[list set fullName] 338 339 proc ::tcltest::makeDirectory {name} \ 340 [info body ::tcltest::makeDirectory]\n[list set fullName] 341 342 # Re-export 343 namespace eval ::tcltest { 344 namespace export makeFile makeDirectory 345 } 346 namespace import -force ::tcltest::* 347 } 348} 349 350# ### ### ### ######### ######### ######### 351## Extended functionality, creation of binary temp. files. 352## Also creation of paths for temp. files 353 354proc ::tcltest::makeBinaryFile {data f} { 355 set path [makeFile {} $f] 356 set ch [open $path w] 357 fconfigure $ch -translation binary 358 puts -nonewline $ch $data 359 close $ch 360 return $path 361} 362 363proc ::tcltest::tempPath {path} { 364 variable temporaryDirectory 365 return [file join $temporaryDirectory $path] 366} 367 368namespace eval ::tcltest { 369 namespace export makeBinaryFile tempPath 370} 371namespace import -force ::tcltest::* 372 373# ### ### ### ######### ######### ######### 374## Commands to load files from various locations within the local 375## Tcllib, and the loading of local Tcllib packages. None of them goes 376## through the auto-loader, nor the regular package management, to 377## avoid contamination of the testsuite by packages and code outside 378## of the Tcllib under test. 379 380proc localPath {fname} { 381 return [file join $::tcltest::testsDirectory $fname] 382} 383 384proc tcllibPath {fname} { 385 return [file join $::tcllib::testutils::tcllib $fname] 386} 387 388proc useLocalFile {fname} { 389 return [uplevel 1 [list source [localPath $fname]]] 390} 391 392proc useTcllibFile {fname} { 393 return [uplevel 1 [list source [tcllibPath $fname]]] 394} 395 396proc use {fname pname args} { 397 set nsname ::$pname 398 if {[llength $args]} {set nsname [lindex $args 0]} 399 400 package forget $pname 401 catch {namespace delete $nsname} 402 403 if {[catch { 404 uplevel 1 [list useTcllibFile $fname] 405 } msg]} { 406 puts " Aborting the tests found in \"[file tail [info script]]\"" 407 puts " Error in [file tail $fname]: $msg" 408 return -code error "" 409 } 410 411 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" 412 return 413} 414 415proc useKeep {fname pname args} { 416 set nsname ::$pname 417 if {[llength $args]} {set nsname [lindex $args 0]} 418 419 package forget $pname 420 421 # Keep = Keep the existing namespace of the package. 422 # = Do not delete it. This is required if the 423 # namespace contains commands created by a 424 # binary package, like 'tcllibc'. They cannot 425 # be re-created. 426 ## 427 ## catch {namespace delete $nsname} 428 429 if {[catch { 430 uplevel 1 [list useTcllibFile $fname] 431 } msg]} { 432 puts " Aborting the tests found in \"[file tail [info script]]\"" 433 puts " Error in [file tail $fname]: $msg" 434 return -code error "" 435 } 436 437 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" 438 return 439} 440 441proc useLocal {fname pname args} { 442 set nsname ::$pname 443 if {[llength $args]} {set nsname [lindex $args 0]} 444 445 package forget $pname 446 catch {namespace delete $nsname} 447 448 if {[catch { 449 uplevel 1 [list useLocalFile $fname] 450 } msg]} { 451 puts " Aborting the tests found in \"[file tail [info script]]\"" 452 puts " Error in [file tail $fname]: $msg" 453 return -code error "" 454 } 455 456 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" 457 return 458} 459 460proc useLocalKeep {fname pname args} { 461 set nsname ::$pname 462 if {[llength $args]} {set nsname [lindex $args 0]} 463 464 package forget $pname 465 466 # Keep = Keep the existing namespace of the package. 467 # = Do not delete it. This is required if the 468 # namespace contains commands created by a 469 # binary package, like 'tcllibc'. They cannot 470 # be re-created. 471 ## 472 ## catch {namespace delete $nsname} 473 474 if {[catch { 475 uplevel 1 [list useLocalFile $fname] 476 } msg]} { 477 puts " Aborting the tests found in \"[file tail [info script]]\"" 478 puts " Error in [file tail $fname]: $msg" 479 return -code error "" 480 } 481 482 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" 483 return 484} 485 486proc useAccel {acc fname pname args} { 487 set use [expr {$acc ? "useKeep" : "use"}] 488 uplevel 1 [linsert $args 0 $use $fname $pname] 489} 490 491proc support {script} { 492 set ::tcllib::testutils::tag "-" 493 if {[catch { 494 uplevel 1 $script 495 } msg]} { 496 set prefix "SETUP Error (Support): " 497 puts $prefix[join [split $::errorInfo \n] "\n$prefix"] 498 499 return -code return 500 } 501 return 502} 503 504proc testing {script} { 505 set ::tcllib::testutils::tag "*" 506 if {[catch { 507 uplevel 1 $script 508 } msg]} { 509 set prefix "SETUP Error (Testing): " 510 puts $prefix[join [split $::errorInfo \n] "\n$prefix"] 511 512 return -code return 513 } 514 return 515} 516 517proc useTcllibC {} { 518 set index [tcllibPath tcllibc/pkgIndex.tcl] 519 if {![file exists $index]} {return 0} 520 521 set ::dir [file dirname $index] 522 uplevel #0 [list source $index] 523 unset ::dir 524 525 package require tcllibc 526 527 puts "$::tcllib::testutils::tag tcllibc [package present tcllibc]" 528 puts "$::tcllib::testutils::tag tcllibc = [package ifneeded tcllibc [package present tcllibc]]" 529 return 1 530} 531 532# ### ### ### ######### ######### ######### 533## General utilities 534 535# - dictsort - 536# 537# Sort a dictionary by its keys. I.e. reorder the contents of the 538# dictionary so that in its list representation the keys are found in 539# ascending alphabetical order. In other words, this command creates 540# a canonical list representation of the input dictionary, suitable 541# for direct comparison. 542# 543# Arguments: 544# dict: The dictionary to sort. 545# 546# Result: 547# The canonical representation of the dictionary. 548 549proc dictsort {dict} { 550 array set a $dict 551 set out [list] 552 foreach key [lsort [array names a]] { 553 lappend out $key $a($key) 554 } 555 return $out 556} 557 558# ### ### ### ######### ######### ######### 559## Putting strings together, if they cannot be expressed easily as one 560## string due to quoting problems. 561 562proc cat {args} { 563 return [join $args ""] 564} 565 566# ### ### ### ######### ######### ######### 567## Mini-logging facility, can also be viewed as an accumulator for 568## complex results. 569# 570# res! : clear accumulator. 571# res+ : add arguments to accumulator. 572# res? : query contents of accumulator. 573# res?lines : query accumulator and format as 574# multiple lines, one per list element. 575 576proc res! {} { 577 variable result {} 578 return 579} 580 581proc res+ {args} { 582 variable result 583 lappend result $args 584 return 585} 586 587proc res? {} { 588 variable result 589 return $result 590} 591 592proc res?lines {} { 593 return [join [res?] \n] 594} 595 596# ### ### ### ######### ######### ######### 597## Helper commands to deal with packages 598## which have multiple implementations, i.e. 599## their pure Tcl base line and one or more 600## accelerators. We are assuming a specific 601## API for accessing the data about available 602## accelerators, switching between them, etc. 603 604# == Assumed API == 605# 606# KnownImplementations -- 607# Returns list of all known implementations. 608# 609# Implementations -- 610# Returns list of activated implementations. 611# A subset of 'KnownImplementations' 612# 613# Names -- 614# Returns dict mapping all known implementations 615# to human-readable strings for output during a 616# test run 617# 618# LoadAccelerator accel -- 619# Tries to make the implementation named 620# 'accel' available for use. Result is boolean. 621# True indicates a successful activation. 622# 623# SwitchTo accel -- 624# Activate the implementation named 'accel'. 625# The empty string disables all implementations. 626 627proc TestAccelInit {namespace} { 628 # Disable all implementations ... Base state. 629 ${namespace}::SwitchTo {} 630 631 # List the implementations. 632 array set map [${namespace}::Names] 633 foreach e [${namespace}::KnownImplementations] { 634 if {[${namespace}::LoadAccelerator $e]} { 635 puts "> $map($e)" 636 } 637 } 638 return 639} 640 641proc TestAccelDo {namespace var script} { 642 upvar 1 $var impl 643 foreach impl [${namespace}::Implementations] { 644 ${namespace}::SwitchTo $impl 645 uplevel 1 $script 646 } 647 return 648} 649 650proc TestAccelExit {namespace} { 651 # Reset the system to a fully inactive state. 652 ${namespace}::SwitchTo {} 653 return 654} 655 656# ### ### ### ######### ######### ######### 657## 658 659proc TestFiles {pattern} { 660 if {[package vsatisfies [package provide Tcl] 8.3]} { 661 # 8.3+ -directory ok 662 set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern] 663 } else { 664 # 8.2 or less, no -directory 665 set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]] 666 } 667 foreach f [lsort -dict $flist] { 668 uplevel 1 [list source $f] 669 } 670 return 671} 672 673proc TestFilesGlob {pattern} { 674 if {[package vsatisfies [package provide Tcl] 8.3]} { 675 # 8.3+ -directory ok 676 set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern] 677 } else { 678 # 8.2 or less, no -directory 679 set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]] 680 } 681 return [lsort -dict $flist] 682} 683 684# ### ### ### ######### ######### ######### 685## 686 687::tcllib::testutils::SaveEnvironment 688 689# ### ### ### ######### ######### ######### 690package provide tcllib::testutils $::tcllib::testutils::version 691puts "- tcllib::testutils [package present tcllib::testutils]" 692return 693