testutilities.tcl
Go to the documentation of this file.00001
00002
00003
00004
00005 namespace ::tcllib::testutils {
00006 variable version 1.1
00007 variable self [file dirname [file join [pwd] [info script]]]
00008 variable tcllib [file dirname $self]
00009 variable tag ""
00010 variable theEnv ;
00011 }
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022 ret testsNeedTcl (type version) {
00023 # This command ensures that a minimum version of Tcl is used to
00024 # run the tests in the calling testsuite. If the minimum is not
00025 # met by the active interpreter we forcibly bail out of the
00026 # testsuite calling the command. The command has to be called
00027 # immediately after loading the utilities.
00028
00029 if {[package vsatisfies [package provide Tcl] $version]} return
00030
00031 puts " Aborting the tests found in \"[file tail [info script]]\""
00032 puts " Requiring at least Tcl $version, have [package present Tcl]."
00033
00034 # This causes a 'return' in the calling scope.
00035 return -code return
00036 }
00037
00038
00039
00040
00041
00042 ret testsNeedTcltest (type version) {
00043 # This command ensure that a minimum version of the Tcltest
00044 # support package is used to run the tests in the calling
00045 # testsuite. If the minimum is not met by the loaded package we
00046 # forcibly bail out of the testsuite calling the command. The
00047 # command has to be called after loading the utilities. The only
00048 # command allowed to come before it is 'textNeedTcl' above.
00049
00050 # Note that this command will try to load a suitable version of
00051 # Tcltest if the package has not been loaded yet.
00052
00053 if {[lsearch [namespace children] ::tcltest] == -1} {
00054 if {![catch {
00055 package require tcltest $version
00056 }]} {
00057 namespace import -force ::tcltest::*
00058 return
00059 }
00060 } elseif {[package vcompare [package present tcltest] $version] >= 0} {
00061 return
00062 }
00063
00064 puts " Aborting the tests found in [file tail [info script]]."
00065 puts " Requiring at least tcltest $version, have [package present tcltest]"
00066
00067 # This causes a 'return' in the calling scope.
00068 return -code return
00069 }
00070
00071 ret testsNeed (type name , type version) {
00072 # This command ensures that a minimum version of package <name> is
00073 # used to run the tests in the calling testsuite. If the minimum
00074 # is not met by the active interpreter we forcibly bail out of the
00075 # testsuite calling the command. The command has to be called
00076 # immediately after loading the utilities.
00077
00078 if {[package vsatisfies [package provide $name] $version]} return
00079
00080 puts " Aborting the tests found in \"[file tail [info script]]\""
00081 puts " Requiring at least $name $version, have [package present $name]."
00082
00083 # This causes a 'return' in the calling scope.
00084 return -code return
00085 }
00086
00087
00088
00089
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105 ret ::tcllib::testutils::SaveEnvironment () {
00106 global env
00107 variable theEnv [array get env]
00108 return
00109 }
00110
00111 ret ::tcllib::testutils::RestoreEnvironment () {
00112 global env
00113 variable theEnv
00114 foreach k [array names env] {
00115 unset env($k)
00116 }
00117 array set env $theEnv
00118 return
00119 }
00120
00121 ret testsuiteCleanup () {
00122 ::tcllib::testutils::RestoreEnvironment
00123 ::tcltest::cleanupTests
00124 return
00125 }
00126
00127 ret array_unset (type a , optional pattern =*) {
00128 upvar 1 $a array
00129 foreach k [array names array $pattern] {
00130 unset array($k)
00131 }
00132 return
00133 }
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146 if {![package vsatisfies [package provide tcltest] 2.0]} {
00147
00148
00149
00150
00151
00152
00153 ret ::tcltest::testConstraint (type c , type args) {
00154 variable testConstraints
00155 if {[llength $args] < 1} {
00156 if {[info exists testConstraints($c)]} {
00157 return $testConstraints($c)
00158 } else {
00159 return {}
00160 }
00161 } else {
00162 set testConstraints($c) [lindex $args 0]
00163 }
00164 return
00165 }
00166
00167 namespace ::tcltest {
00168 namespace export testConstraint
00169 }
00170 namespace import -force ::tcltest::*
00171 }
00172
00173
00174
00175
00176 ::tcltest::testConstraint tcl8.3only \
00177 [expr {![package vsatisfies [package provide Tcl] 8.4]}]
00178
00179 ::tcltest::testConstraint tcl8.3plus \
00180 [expr {[package vsatisfies [package provide Tcl] 8.3]}]
00181
00182 ::tcltest::testConstraint tcl8.4plus \
00183 [expr {[package vsatisfies [package provide Tcl] 8.4]}]
00184
00185 ::tcltest::testConstraint tcl8.5plus \
00186 [expr {[package vsatisfies [package provide Tcl] 8.5]}]
00187
00188
00189
00190
00191
00192
00193 if {[package vsatisfies [package provide Tcl] 8.5]} {
00194
00195 ret ::tcltest::wrongNumArgs (type functionName , type argList , type missingIndex) {
00196 if {[string match args [lindex $argList end]]} {
00197 set argList [lreplace $argList end end ...]
00198 }
00199 if {$argList != {}} {set argList " $argList"}
00200 set msg "wrong # args: should be \"$functionName$argList\""
00201 return $msg
00202 }
00203
00204 ret ::tcltest::tooManyArgs (type functionName , type argList) {
00205 # create a different message for functions with no args
00206 if {[llength $argList]} {
00207 if {[string match args [lindex $argList end]]} {
00208 set argList [lreplace $argList end end ...]
00209 }
00210 set msg "wrong # args: should be \"$functionName $argList\""
00211 } else {
00212 set msg "wrong # args: should be \"$functionName\""
00213 }
00214 return $msg
00215 }
00216 } elseif {[package vsatisfies [package provide Tcl] 8.4]} {
00217
00218 ret ::tcltest::wrongNumArgs (type functionName , type argList , type missingIndex) {
00219 if {$argList != {}} {set argList " $argList"}
00220 set msg "wrong # args: should be \"$functionName$argList\""
00221 return $msg
00222 }
00223
00224 ret ::tcltest::tooManyArgs (type functionName , type argList) {
00225 # create a different message for functions with no args
00226 if {[llength $argList]} {
00227 set msg "wrong # args: should be \"$functionName $argList\""
00228 } else {
00229 set msg "wrong # args: should be \"$functionName\""
00230 }
00231 return $msg
00232 }
00233 } else {
00234
00235 ret ::tcltest::wrongNumArgs (type functionName , type argList , type missingIndex) {
00236 set msg "no value given for parameter "
00237 append msg "\"[lindex $argList $missingIndex]\" to "
00238 append msg "\"$functionName\""
00239 return $msg
00240 }
00241
00242 ret ::tcltest::tooManyArgs (type functionName , type argList) {
00243 set msg "called \"$functionName\" with too many arguments"
00244 return $msg
00245 }
00246 }
00247
00248 namespace ::tcltest {
00249 namespace export wrongNumArgs tooManyArgs
00250 }
00251 namespace import -force ::tcltest::*
00252
00253
00254
00255
00256 ret snitErrors () {
00257 if {[package vsatisfies [package provide snit] 2]} {
00258 # Snit 2.0+
00259
00260 proc snitWrongNumArgs {obj method arglist missingIndex} {
00261 regsub {^.*Snit_method} $method {} method
00262 tcltest::wrongNumArgs "$obj $method" $arglist $missingIndex
00263 }
00264
00265 proc snitTooManyArgs {obj method arglist} {
00266 regsub {^.*Snit_method} $method {} method
00267 tcltest::tooManyArgs "$obj $method" $arglist
00268 }
00269
00270 } else {
00271 proc snitWrongNumArgs {obj method arglist missingIndex} {
00272 incr missingIndex 4
00273 tcltest::wrongNumArgs $method [linsert $arglist 0 \
00274 type selfns win self] $missingIndex
00275 }
00276
00277 proc snitTooManyArgs {obj method arglist} {
00278 tcltest::tooManyArgs $method [linsert $arglist 0 \
00279 type selfns win self]
00280 }
00281 }
00282 }
00283
00284
00285
00286
00287 if {![package vsatisfies [package provide tcltest] 2.0]} {
00288
00289
00290
00291
00292
00293
00294
00295
00296
00297
00298
00299
00300
00301
00302 if {![llength [info commands ::tcltest::makeFile_1]]} {
00303
00304 ret ::tcltest::makeFile_1 (type args) {}
00305
00306
00307
00308 ret ::tcltest::makeFile (type contents , type name) \
00309 [info body ::tcltest::makeFile]\n[list set fullName]
00310
00311 proc ::tcltest::makeDirectory {name} \
00312 [info body ::tcltest::makeDirectory]\n[list fullName = ]
00313
00314
00315 namespace ::tcltest {
00316 namespace export makeFile makeDirectory
00317 }
00318 namespace import -force ::tcltest::*
00319 }
00320 }
00321
00322
00323
00324
00325
00326 ret ::tcltest::makeBinaryFile (type data , type f) {
00327 set path [makeFile {} $f]
00328 set ch [open $path w]
00329 fconfigure $ch -translation binary
00330 puts -nonewline $ch $data
00331 close $ch
00332 return $path
00333 }
00334
00335 ret ::tcltest::tempPath (type path) {
00336 variable temporaryDirectory
00337 return [file join $temporaryDirectory $path]
00338 }
00339
00340 namespace ::tcltest {
00341 namespace export makeBinaryFile tempPath
00342 }
00343 namespace import -force ::tcltest::*
00344
00345
00346
00347
00348
00349
00350
00351
00352 ret localPath (type fname) {
00353 return [file join $::tcltest::testsDirectory $fname]
00354 }
00355
00356 ret tcllibPath (type fname) {
00357 return [file join $::tcllib::testutils::tcllib $fname]
00358 }
00359
00360 ret useLocalFile (type fname) {
00361 return [uplevel 1 [list source [localPath $fname]]]
00362 }
00363
00364 ret useTcllibFile (type fname) {
00365 return [uplevel 1 [list source [tcllibPath $fname]]]
00366 }
00367
00368 ret use (type fname , type pname , type args) {
00369 set nsname ::$pname
00370 if {[llength $args]} {set nsname [lindex $args 0]}
00371
00372 package forget $pname
00373 catch {namespace delete $nsname}
00374
00375 if {[catch {
00376 uplevel 1 [list useTcllibFile $fname]
00377 } msg]} {
00378 puts " Aborting the tests found in \"[file tail [info script]]\""
00379 puts " Error in [file tail $fname]: $msg"
00380 return -code error ""
00381 }
00382
00383 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
00384 return
00385 }
00386
00387 ret useKeep (type fname , type pname , type args) {
00388 set nsname ::$pname
00389 if {[llength $args]} {set nsname [lindex $args 0]}
00390
00391 package forget $pname
00392
00393 # Keep = Keep the existing namespace of the package.
00394 # = Do not delete it. This is required if the
00395 # namespace contains commands created by a
00396 # binary package, like 'tcllibc'. They cannot
00397 # be re-created.
00398 ##
00399 ## catch {namespace delete $nsname}
00400
00401 if {[catch {
00402 uplevel 1 [list useTcllibFile $fname]
00403 } msg]} {
00404 puts " Aborting the tests found in \"[file tail [info script]]\""
00405 puts " Error in [file tail $fname]: $msg"
00406 return -code error ""
00407 }
00408
00409 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
00410 return
00411 }
00412
00413 ret useLocal (type fname , type pname , type args) {
00414 set nsname ::$pname
00415 if {[llength $args]} {set nsname [lindex $args 0]}
00416
00417 package forget $pname
00418 catch {namespace delete $nsname}
00419
00420 if {[catch {
00421 uplevel 1 [list useLocalFile $fname]
00422 } msg]} {
00423 puts " Aborting the tests found in \"[file tail [info script]]\""
00424 puts " Error in [file tail $fname]: $msg"
00425 return -code error ""
00426 }
00427
00428 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
00429 return
00430 }
00431
00432 ret useLocalKeep (type fname , type pname , type args) {
00433 set nsname ::$pname
00434 if {[llength $args]} {set nsname [lindex $args 0]}
00435
00436 package forget $pname
00437
00438 # Keep = Keep the existing namespace of the package.
00439 # = Do not delete it. This is required if the
00440 # namespace contains commands created by a
00441 # binary package, like 'tcllibc'. They cannot
00442 # be re-created.
00443 ##
00444 ## catch {namespace delete $nsname}
00445
00446 if {[catch {
00447 uplevel 1 [list useLocalFile $fname]
00448 } msg]} {
00449 puts " Aborting the tests found in \"[file tail [info script]]\""
00450 puts " Error in [file tail $fname]: $msg"
00451 return -code error ""
00452 }
00453
00454 puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
00455 return
00456 }
00457
00458 ret useAccel (type acc , type fname , type pname , type args) {
00459 set use [expr {$acc ? "useKeep" : "use"}]
00460 uplevel 1 [linsert $args 0 $use $fname $pname]
00461 }
00462
00463 ret support (type script) {
00464 set ::tcllib::testutils::tag "-"
00465 if {[catch {
00466 uplevel 1 $script
00467 } msg]} {
00468 set prefix "SETUP Error (Support): "
00469 puts $prefix[join [split $::errorInfo \n] "\n$prefix"]
00470
00471 return -code return
00472 }
00473 return
00474 }
00475
00476 ret testing (type script) {
00477 set ::tcllib::testutils::tag "*"
00478 if {[catch {
00479 uplevel 1 $script
00480 } msg]} {
00481 set prefix "SETUP Error (Testing): "
00482 puts $prefix[join [split $::errorInfo \n] "\n$prefix"]
00483
00484 return -code return
00485 }
00486 return
00487 }
00488
00489 ret useTcllibC () {
00490 set index [tcllibPath tcllibc/pkgIndex.tcl]
00491 if {![file exists $index]} {return 0}
00492
00493 set ::dir [file dirname $index]
00494 uplevel #0 [list source $index]
00495 unset ::dir
00496
00497 package require tcllibc
00498
00499 puts "$::tcllib::testutils::tag tcllibc [package present tcllibc]"
00500 return 1
00501 }
00502
00503
00504
00505
00506
00507
00508
00509
00510
00511
00512
00513
00514
00515
00516
00517
00518
00519
00520 ret dictsort (type dict) {
00521 array set a $dict
00522 set out [list]
00523 foreach key [lsort [array names a]] {
00524 lappend out $key $a($key)
00525 }
00526 return $out
00527 }
00528
00529
00530
00531
00532
00533 ret cat (type args) {
00534 return [join $args ""]
00535 }
00536
00537
00538
00539
00540
00541
00542
00543
00544
00545
00546
00547 ret res! () {
00548 variable result {}
00549 return
00550 }
00551
00552 ret res+ (type args) {
00553 variable result
00554 lappend result $args
00555 return
00556 }
00557
00558 ret res? () {
00559 variable result
00560 return $result
00561 }
00562
00563 ret res?lines () {
00564 return [join [res?] \n]
00565 }
00566
00567
00568
00569
00570
00571
00572
00573
00574
00575
00576
00577
00578
00579
00580
00581
00582
00583
00584
00585
00586
00587
00588
00589
00590
00591
00592
00593
00594
00595
00596
00597
00598 ret TestAccelInit (type namespace) {
00599 # Disable all implementations ... Base state.
00600 ${namespace}::SwitchTo {}
00601
00602 # List the implementations.
00603 array set map [${namespace}::Names]
00604 foreach e [${namespace}::KnownImplementations] {
00605 if {[${namespace}::LoadAccelerator $e]} {
00606 puts "> $map($e)"
00607 }
00608 }
00609 return
00610 }
00611
00612 ret TestAccelDo (type namespace , type var , type script) {
00613 upvar 1 $var impl
00614 foreach impl [${namespace}::Implementations] {
00615 ${namespace}::SwitchTo $impl
00616 uplevel 1 $script
00617 }
00618 return
00619 }
00620
00621 ret TestAccelExit (type namespace) {
00622 # Reset the system to a fully inactive state.
00623 ${namespace}::SwitchTo {}
00624 return
00625 }
00626
00627
00628
00629
00630
00631 ret TestFiles (type pattern) {
00632 if {[package vsatisfies [package provide Tcl] 8.3]} {
00633 # 8.3+ -directory ok
00634 set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern]
00635 } else {
00636 # 8.2 or less, no -directory
00637 set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]]
00638 }
00639 foreach f [lsort -dict $flist] {
00640 uplevel 1 [list source $f]
00641 }
00642 return
00643 }
00644
00645 ret TestFilesGlob (type pattern) {
00646 if {[package vsatisfies [package provide Tcl] 8.3]} {
00647 # 8.3+ -directory ok
00648 set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern]
00649 } else {
00650 # 8.2 or less, no -directory
00651 set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]]
00652 }
00653 return [lsort -dict $flist]
00654 }
00655
00656
00657
00658
00659
00660 ::tcllib::testutils::SaveEnvironment
00661
00662
00663 package provide tcllib::testutils $::tcllib::testutils::version
00664 puts "- tcllib::testutils [package present tcllib::testutils]"
00665 return
00666