testutilities.tcl

Go to the documentation of this file.
00001 /*  -*- tcl -*-*/
00002 /*  Testsuite utilities / boilerplate*/
00003 /*  Copyright (c) 2006, Andreas Kupries <andreas_kupries@users.sourceforge.net>*/
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  ; /*  Saved environment.*/
00011 }
00012 
00013 /*  ### ### ### ######### ######### #########*/
00014 /*  Commands for common functions and boilerplate actions required by*/
00015 /*  many testsuites of Tcllib modules and packages in a central place*/
00016 /*  for easier maintenance.*/
00017 
00018 /*  ### ### ### ######### ######### #########*/
00019 /*  Declare the minimal version of Tcl required to run the package*/
00020 /*  tested by this testsuite, and its dependencies.*/
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 /*  Declare the minimum version of Tcltest required to run the*/
00040 /*  testsuite.*/
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 /*  Save/restore the environment, for testsuites which have to*/
00090 /*  manipulate it to (1) either achieve the effects they test*/
00091 /*  for/against, or (2) to shield themselves against manipulation by*/
00092 /*  the environment. We have examples for both in 'fileutil' (1), and*/
00093 /*  'doctools' (2).*/
00094 /** 
00095  *# Saving is done automatically at the beginning of a test file,
00096  *# through this module. Restoration is done semi-automatically.  We
00097  *# __cannot__ hook into the tcltest cleanup hook It is already used by
00098  *# all.tcl to transfer the information from the slave doing the actual
00099  *# tests to the master. Here the hook is only an alias, and
00100  *# unmodifiable. We create a new cleanup command which runs both our
00101  *# environment cleanup, and the regular one. All .test files are
00102  *# modified to use the new cleanup.
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 /*  Newer versions of the Tcltest support package for testsuite provide*/
00137 /*  various features which make the creation and maintenance of*/
00138 /*  testsuites much easier. I consider it important to have these*/
00139 /*  features even if an older version of Tcltest is loaded. To this end*/
00140 /*  we now provide emulations and implementations, conditional on the*/
00141 /*  version of Tcltest found to be active.*/
00142 
00143 /*  ### ### ### ######### ######### #########*/
00144 /*  Easy definition and initialization of test constraints.*/
00145 
00146 if {![package vsatisfies [package provide tcltest] 2.0]} {
00147     /*  Tcltest 2.0+ provides a documented public API to define and*/
00148     /*  initialize a test constraint. For earlier versions of the*/
00149     /*  package the user has to directly set a non-public undocumented*/
00150     /*  variable in the package's namespace. We create a command doing*/
00151     /*  this and emulating the public API.*/
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 /*  Define a set of standard constraints*/
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 /*  Cross-version code for the generation of the error messages created*/
00190 /*  by Tcl procedures when called with the wrong number of arguments,*/
00191 /*  either too many, or not enough.*/
00192 
00193 if {[package vsatisfies [package provide Tcl] 8.5]} {
00194     /*  8.5+*/
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     /*  8.4+*/
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     /*  8.2+*/
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 /*  Command to construct wrong/args messages for Snit methods.*/
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 /*  tclTest::makeFile result API changed for 2.0*/
00286 
00287 if {![package vsatisfies [package provide tcltest] 2.0]} {
00288 
00289     /*  The 'makeFile' in Tcltest 1.0 returns a list of all the paths*/
00290     /*  generated so far, whereas the 'makeFile' in 2.0+ returns only*/
00291     /*  the path of the newly generated file. We standardize on the more*/
00292     /*  useful behaviour of 2.0+. If 1.x is present we have to create an*/
00293     /*  emulation layer to get the wanted result.*/
00294 
00295     /*  1.0 is not fully correctly described. If the file was created*/
00296     /*  before no list is returned at all. We force things by adding a*/
00297     /*  line to the old procedure which makes the result unconditional*/
00298     /*  (the name of the file/dir created).*/
00299 
00300     /*  The same change applies to 'makeDirectory'*/
00301 
00302     if {![llength [info commands ::tcltest::makeFile_1]]} {
00303     /*  Marker first.*/
00304     ret  ::tcltest::makeFile_1 (type args) {}
00305 
00306     /*  Extend procedures with command to return the required full*/
00307     /*  name.*/
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     /*  Re-export*/
00315     namespace ::tcltest {
00316         namespace export makeFile makeDirectory
00317     }
00318     namespace import -force ::tcltest::*
00319     }
00320 }
00321 
00322 /*  ### ### ### ######### ######### #########*/
00323 /*  Extended functionality, creation of binary temp. files.*/
00324 /*  Also creation of paths for temp. files*/
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 /*  Commands to load files from various locations within the local*/
00347 /*  Tcllib, and the loading of local Tcllib packages. None of them goes*/
00348 /*  through the auto-loader, nor the regular package management, to*/
00349 /*  avoid contamination of the testsuite by packages and code outside*/
00350 /*  of the Tcllib under test.*/
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 /*  General utilities*/
00505 
00506 /*  - dictsort -*/
00507 /* */
00508 /*   Sort a dictionary by its keys. I.e. reorder the contents of the*/
00509 /*   dictionary so that in its list representation the keys are found in*/
00510 /*   ascending alphabetical order. In other words, this command creates*/
00511 /*   a canonical list representation of the input dictionary, suitable*/
00512 /*   for direct comparison.*/
00513 /* */
00514 /*  Arguments:*/
00515 /*  dict:   The dictionary to sort.*/
00516 /* */
00517 /*  Result:*/
00518 /*  The canonical representation of the dictionary.*/
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 /*  Putting strings together, if they cannot be expressed easily as one*/
00531 /*  string due to quoting problems.*/
00532 
00533 ret  cat (type args) {
00534     return [join $args ""]
00535 }
00536 
00537 /*  ### ### ### ######### ######### #########*/
00538 /*  Mini-logging facility, can also be viewed as an accumulator for*/
00539 /*  complex results.*/
00540 /* */
00541 /*  res!      : clear accumulator.*/
00542 /*  res+      : add arguments to accumulator.*/
00543 /*  res?      : query contents of accumulator.*/
00544 /*  res?lines : query accumulator and format as*/
00545 /*              multiple lines, one per list element.*/
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 /*  Helper commands to deal with packages*/
00569 /*  which have multiple implementations, i.e.*/
00570 /*  their pure Tcl base line and one or more*/
00571 /*  accelerators. We are assuming a specific*/
00572 /*  API for accessing the data about available*/
00573 /*  accelerators, switching between them, etc.*/
00574 
00575 /*  == Assumed API ==*/
00576 /* */
00577 /*  KnownImplementations --*/
00578 /*    Returns list of all known implementations.*/
00579 /* */
00580 /*  Implementations --*/
00581 /*    Returns list of activated implementations.*/
00582 /*    A subset of 'KnownImplementations'*/
00583 /* */
00584 /*  Names --*/
00585 /*    Returns dict mapping all known implementations*/
00586 /*    to human-readable strings for output during a*/
00587 /*    test run*/
00588 /* */
00589 /*  LoadAccelerator accel --*/
00590 /*    Tries to make the implementation named*/
00591 /*    'accel' available for use. Result is boolean.*/
00592 /*    True indicates a successful activation.*/
00593 /* */
00594 /*  SwitchTo accel --*/
00595 /*    Activate the implementation named 'accel'.*/
00596 /*    The empty string disables all implementations.*/
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 

Generated on 21 Sep 2010 for Gui by  doxygen 1.6.1