tcllib-1.10/support/devel/all.tcl

Go to the documentation of this file.

/*  all.tcl --*/
/* */
/*  This file contains a top-level script to run all of the Tcl*/
/*  tests.  Execute it by invoking "tclsh all.test" in this directory.*/
/* */
/*  To test a subset of the modules, invoke it by 'tclsh all.test -modules "<module list>"'*/
/* */
/*  Copyright (c) 1998-2000 by Ajuba Solutions.*/
/*  All rights reserved.*/
/*  */
/*  RCS: @(#) $Id: all.tcl,v 1.6 2006/10/10 06:07:18 andreas_kupries Exp $*/

catch {wm withdraw .}

 old = _auto_path $auto_path

if {[lsearch [namespace children] ::tcltest] == -1} {
    namespace ::tcltest {}
    ret  ::tcltest::processCmdLineArgsAddFlagsHook () {
    return [list -modules]
    }
    ret  ::tcltest::processCmdLineArgsHook (type argv) {
    array set foo $argv
    catch {set ::modules $foo(-modules)}
    }
    ret  ::tcltest::cleanupTestsHook (optional c ={)} {
    if { [string equal $c ""] } {
        /*  Ignore calls in the master.*/
        return
    }

    /*  When called from a slave copy the information found in the*/
    /*  slave to here and update our own data.*/

    /*  Get total/pass/skip/fail counts*/
    array  foo =  [$c eval {array get ::tcltest::numTests}]
    foreach index {Total Passed Skipped Failed} {
        incr ::tcltest::numTests($index) $foo($index)
    }
    incr ::tcltest::numTestFiles

    /*  Append the list of failFiles if necessary*/
     f =  [$c eval {
         ff =  $::tcltest::failFiles
        if {($::tcltest::currentFailure) && \
            ([lsearch -exact $ff $testFileName] == -1)} {
         res =  [file join $::tcllibModule $testFileName]
        } else {
         res =  ""
        }
         res = 
    }] ; /*  {}*/
    if { ![string equal $f ""] } {
        lappend ::tcltest::failFiles $f
    }

    /*  Get the "skipped because" information*/
    un foo = 
    array  foo =  [$c eval {array get ::tcltest::skippedBecause}]
    foreach constraint [array names foo] {
        if { ![info exists ::tcltest::skippedBecause($constraint)] } {
         ::tcltest = ::skippedBecause($constraint) $foo($constraint)
        } else {
        incr ::tcltest::skippedBecause($constraint) $foo($constraint)
        }
    }

    /*  Clean out the state in the slave*/
    $c eval {
        foreach index {Total Passed Skipped Failed} {
         ::tcltest = ::numTests($index) 0
        }
         ::tcltest = ::failFiles {}
        foreach constraint [array names ::tcltest::skippedBecause] {
        un ::tcltest = ::skippedBecause($constraint)
        }
    }
    }

    package require tcltest
    namespace import ::tcltest::*
}

 ::tcltest = ::testSingleFile false
 ::tcltest = ::testsDirectory [file dirname \
    [file dirname [file dirname [info script]]]]

/*  We need to ensure that the testsDirectory is absolute*/
if {[catch {::tcltest::normalizePath ::tcltest::testsDirectory}]} {
    /*  The version of tcltest we have here does not support*/
    /*  'normalizePath', so we have to do this on our own.*/

     oldpwd =  [pwd]
    catch {cd $::tcltest::testsDirectory}
     ::tcltest = ::testsDirectory [pwd]
    cd $oldpwd
}
 root =  $::tcltest::testsDirectory

ret  Note (type k , type v) {
    puts  stdout [list @@ $k $v]
    flush stdout
    return
}
ret  Now () {return [clock seconds]}

puts stdout ""
Note Host       [info hostname]
Note Platform   $tcl_platform(os)-$tcl_platform(osVersion)-$tcl_platform(machine)
Note CWD        $::tcltest::testsDirectory
Note Shell      [info nameofexecutable]
Note Tcl        [info patchlevel]

/*  Host  => Platform | Identity of the Test environment.*/
/*  Shell => Tcl      |*/
/*  CWD               | Identity of the Tcllib under test.*/

if {[llength $::tcltest::skip]}       {Note SkipTests  $::tcltest::skip}
if {[llength $::tcltest::match]}      {Note MatchTests $::tcltest::match}
if {[llength $::tcltest::skipFiles]}  {Note SkipFiles  $::tcltest::skipFiles}
if {[llength $::tcltest::matchFiles]} {Note MatchFiles $::tcltest::matchFiles}

 auto = _path $old_auto_path
 auto = _path [linsert $auto_path 0 [file join $root modules]]
 old = _apath $auto_path

/** 
 *# Take default action if the modules are not specified
 *#
 */

if {![info exists modules]} then {
    foreach module [glob [file join $root modules]/*/*.test] {
     tmp = ([lindex [file split $module] end-1]) 1
    }
     modules =  [lsort -dict [array names tmp]]
    un tmp = 
}

Note Start [Now]

foreach module $modules {
     ::tcltest = ::testsDirectory [file join $root modules $module]

    if { ![file isdirectory $::tcltest::testsDirectory] } {
    puts stdout "unknown module $module"
    }

     auto = _path $old_apath
     auto = _path [linsert $auto_path 0 $::tcltest::testsDirectory]

    /*  For each module, make a slave interp and source that module's*/
    /*  tests into the slave. This isolates the test suites from one*/
    /*  another.*/

    Note Module [file tail $module]

     c =  [interp create]
    interp alias $c pSet {} 
    interp =  alias $c Note {} Note

    $c eval {
    /*  import the auto_path from the parent interp,*/
    /*  so "package require" works*/

     ::auto = _path    [pSet ::auto_path]
     ::argv0 =         [pSet ::argv0]
     ::tcllibModule =  [pSet module]

    /*  The next command allows the execution of 'tk' constrained*/
    /*  tests, if Tk is present (for example when this code is run*/
    /*  run by 'wish').*/

    /*  Under wish 8.2/8.3 we have to explicitly load Tk into the*/
    /*  slave, the package management is not able to.*/

    if {![package vsatisfies [package provide Tcl] 8.4]} {
        catch {
        
        wm withdraw .
        }
    } else {
        catch {
        package require Tk
        wm withdraw .
        }
    }

    package require tcltest

    /*  Re-import, the loading of an older tcltest package reset it*/
    /*  to the standard set of paths.*/
     ::auto = _path [pSet ::auto_path]

    namespace import ::tcltest::*
     ::tcltest = ::testSingleFile false
     ::tcltest = ::testsDirectory [pSet ::tcltest::testsDirectory]

    /*  configure not present in tcltest 1.x*/
    if {[catch {::tcltest::configure -verbose bstep}]} {
         ::tcltest = ::verbose psb
    }
    }

    interp alias \
        $c ::tcltest::cleanupTestsHook \
        {} ::tcltest::cleanupTestsHook $c

    /*  source each of the specified tests*/
    foreach file [lsort [::tcltest::getMatchingFiles]] {
     tail =  [file tail $file]
    Note Testsuite [string map [list "$root/" ""] $file]
    $c eval {
        if {[catch {source [pSet file]} msg]} {
        puts stdout "@+"
        puts stdout @|[join [split $errorInfo \n] "\n@|"]
        puts stdout "@-"
        }
    }
    }
    interp delete $c
    puts stdout ""
}

/*  cleanup*/
Note End [Now]
::tcltest::cleanupTests 1
/*  FRINK: nocheck*/
/*  Use of 'exit' ensures proper termination of the test system when*/
/*  driven by a 'wish' instead of a 'tclsh'. Otherwise 'wish' would*/
/*  enter its regular event loop and no tests would complete.*/
exit