1# all.tcl -- 2# 3# This file contains a top-level script to run all of the Tcl 4# tests. Execute it by invoking "tclsh all.test" in this directory. 5# 6# To test a subset of the modules, invoke it by 'tclsh all.test -modules "<module list>"' 7# 8# Copyright (c) 1998-2000 by Ajuba Solutions. 9# All rights reserved. 10# 11# RCS: @(#) $Id: all.tcl,v 1.7 2009/12/08 21:00:51 andreas_kupries Exp $ 12 13catch {wm withdraw .} 14 15set old_auto_path $auto_path 16 17if {[lsearch [namespace children] ::tcltest] == -1} { 18 namespace eval ::tcltest {} 19 proc ::tcltest::processCmdLineArgsAddFlagsHook {} { 20 return [list -modules] 21 } 22 proc ::tcltest::processCmdLineArgsHook {argv} { 23 array set foo $argv 24 catch {set ::modules $foo(-modules)} 25 } 26 proc ::tcltest::cleanupTestsHook {{c {}}} { 27 if { [string equal $c ""] } { 28 # Ignore calls in the master. 29 return 30 } 31 32 # When called from a slave copy the information found in the 33 # slave to here and update our own data. 34 35 # Get total/pass/skip/fail counts 36 array set foo [$c eval {array get ::tcltest::numTests}] 37 foreach index {Total Passed Skipped Failed} { 38 incr ::tcltest::numTests($index) $foo($index) 39 } 40 incr ::tcltest::numTestFiles 41 42 # Append the list of failFiles if necessary 43 set f [$c eval { 44 set ff $::tcltest::failFiles 45 if {($::tcltest::currentFailure) && \ 46 ([lsearch -exact $ff $testFileName] == -1)} { 47 set res [file join $::tcllibModule $testFileName] 48 } else { 49 set res "" 50 } 51 set res 52 }] ; # {} 53 if { ![string equal $f ""] } { 54 lappend ::tcltest::failFiles $f 55 } 56 57 # Get the "skipped because" information 58 unset foo 59 array set foo [$c eval {array get ::tcltest::skippedBecause}] 60 foreach constraint [array names foo] { 61 if { ![info exists ::tcltest::skippedBecause($constraint)] } { 62 set ::tcltest::skippedBecause($constraint) $foo($constraint) 63 } else { 64 incr ::tcltest::skippedBecause($constraint) $foo($constraint) 65 } 66 } 67 68 # Clean out the state in the slave 69 $c eval { 70 foreach index {Total Passed Skipped Failed} { 71 set ::tcltest::numTests($index) 0 72 } 73 set ::tcltest::failFiles {} 74 foreach constraint [array names ::tcltest::skippedBecause] { 75 unset ::tcltest::skippedBecause($constraint) 76 } 77 } 78 } 79 80 package require tcltest 81 namespace import ::tcltest::* 82} 83 84set ::tcltest::testSingleFile false 85set ::tcltest::testsDirectory [file dirname \ 86 [file dirname [file dirname [info script]]]] 87 88# We need to ensure that the testsDirectory is absolute 89if {[catch {::tcltest::normalizePath ::tcltest::testsDirectory}]} { 90 # The version of tcltest we have here does not support 91 # 'normalizePath', so we have to do this on our own. 92 93 set oldpwd [pwd] 94 catch {cd $::tcltest::testsDirectory} 95 set ::tcltest::testsDirectory [pwd] 96 cd $oldpwd 97} 98set root $::tcltest::testsDirectory 99 100proc Note {k v} { 101 puts stdout [list @@ $k $v] 102 flush stdout 103 return 104} 105proc Now {} {return [clock seconds]} 106 107puts stdout "" 108Note Host [info hostname] 109Note Platform $tcl_platform(os)-$tcl_platform(osVersion)-$tcl_platform(machine) 110Note CWD $::tcltest::testsDirectory 111Note Shell [info nameofexecutable] 112Note Tcl [info patchlevel] 113 114# Host => Platform | Identity of the Test environment. 115# Shell => Tcl | 116# CWD | Identity of the Tcllib under test. 117 118if {[llength $::tcltest::skip]} {Note SkipTests $::tcltest::skip} 119if {[llength $::tcltest::match]} {Note MatchTests $::tcltest::match} 120if {[llength $::tcltest::skipFiles]} {Note SkipFiles $::tcltest::skipFiles} 121if {[llength $::tcltest::matchFiles]} {Note MatchFiles $::tcltest::matchFiles} 122 123set auto_path $old_auto_path 124set auto_path [linsert $auto_path 0 [file join $root modules]] 125set old_apath $auto_path 126 127## 128## Take default action if the modules are not specified 129## 130 131if {![info exists modules]} then { 132 foreach module [glob [file join $root modules]/*/*.test] { 133 set tmp([lindex [file split $module] end-1]) 1 134 } 135 set modules [lsort -dict [array names tmp]] 136 unset tmp 137} 138 139Note Start [Now] 140 141foreach module $modules { 142 set ::tcltest::testsDirectory [file join $root modules $module] 143 144 if { ![file isdirectory $::tcltest::testsDirectory] } { 145 puts stdout "unknown module $module" 146 } 147 148 set auto_path $old_apath 149 set auto_path [linsert $auto_path 0 $::tcltest::testsDirectory] 150 151 # For each module, make a slave interp and source that module's 152 # tests into the slave. This isolates the test suites from one 153 # another. 154 155 Note Module [file tail $module] 156 157 set c [interp create] 158 interp alias $c pSet {} set 159 interp alias $c Note {} Note 160 161 $c eval { 162 # import the auto_path from the parent interp, 163 # so "package require" works 164 165 set ::auto_path [pSet ::auto_path] 166 set ::argv0 [pSet ::argv0] 167 set ::tcllibModule [pSet module] 168 169 # The next command allows the execution of 'tk' constrained 170 # tests, if Tk is present (for example when this code is run 171 # run by 'wish'). 172 173 # Under wish 8.2/8.3 we have to explicitly load Tk into the 174 # slave, the package management is not able to. 175 176 if {![package vsatisfies [package provide Tcl] 8.4]} { 177 catch { 178 load {} Tk 179 wm withdraw . 180 } 181 } else { 182 catch { 183 package require Tk 184 wm withdraw . 185 } 186 } 187 188 package require tcltest 189 190 # Re-import, the loading of an older tcltest package reset it 191 # to the standard set of paths. 192 set ::auto_path [pSet ::auto_path] 193 194 namespace import ::tcltest::* 195 set ::tcltest::testSingleFile false 196 set ::tcltest::testsDirectory [pSet ::tcltest::testsDirectory] 197 198 # configure not present in tcltest 1.x 199 if {[catch {::tcltest::configure -verbose { 200 body skip start error pass usec line 201 }}]} { 202 # ^ body skip start error pass usec line 203 set ::tcltest::verbose psb ;# pass skip body 204 } 205 } 206 207 interp alias \ 208 $c ::tcltest::cleanupTestsHook \ 209 {} ::tcltest::cleanupTestsHook $c 210 211 # source each of the specified tests 212 foreach file [lsort [::tcltest::getMatchingFiles]] { 213 set tail [file tail $file] 214 Note Testsuite [string map [list "$root/" ""] $file] 215 Note StartFile [Now] 216 $c eval { 217 if {[catch {source [pSet file]} msg]} { 218 puts stdout "@+" 219 puts stdout @|[join [split $errorInfo \n] "\n@|"] 220 puts stdout "@-" 221 } 222 } 223 Note EndFile [Now] 224 } 225 interp delete $c 226 puts stdout "" 227} 228 229# cleanup 230Note End [Now] 231::tcltest::cleanupTests 1 232# FRINK: nocheck 233# Use of 'exit' ensures proper termination of the test system when 234# driven by a 'wish' instead of a 'tclsh'. Otherwise 'wish' would 235# enter its regular event loop and no tests would complete. 236exit 237 238