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