1# -*- tcl -*-
2# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
3##
4# ###
5
6package require  sak::test::shell
7package require  sak::registry
8package require  sak::animate
9package require  sak::color
10# TODO: Rework this package to use the sak::feedback package
11
12getpackage textutil::repeat textutil/repeat.tcl
13getpackage fileutil         fileutil/fileutil.tcl
14getpackage struct::matrix   struct/matrix.tcl
15
16namespace eval ::sak::test::run {
17    namespace import ::textutil::repeat::blank
18    namespace import ::sak::color::*
19}
20
21# ###
22
23proc ::sak::test::run {argv} {
24    variable run::valgrind
25    array set config {
26	valgrind 0 raw 0 shells {} stem {} log 0
27    }
28
29    while {[string match -* [set opt [lindex $argv 0]]]} {
30	switch -exact -- $opt {
31	    -s - --shell {
32		set sh [lindex $argv 1]
33		if {![fileutil::test $sh efrx msg "Shell"]} {
34		    sak::test::usage $msg
35		}
36		lappend config(shells) $sh
37		set argv [lrange $argv 2 end]
38	    }
39	    -g - --valgrind {
40		if {![llength $valgrind]} {
41		    sak::test::usage valgrind not found in the PATH
42		}
43		incr config(valgrind)
44		set argv [lrange $argv 1 end]
45	    }
46	    -v {
47		set config(raw) 1
48		set argv [lrange $argv 1 end]
49	    }
50	    -l - --log {
51		set config(log) 1
52		set config(stem) [lindex $argv 1]
53		set argv         [lrange $argv 2 end]
54	    }
55	    default {
56		sak::test::usage Unknown option "\"$opt\""
57	    }
58	}
59    }
60
61    if {$config(log)} {set config(raw) 0}
62
63    if {![sak::util::checkModules argv]} return
64
65    run::Do config $argv
66    return
67}
68
69# ###
70
71proc ::sak::test::run::Do {cv modules} {
72    upvar 1 $cv config
73    variable valgrind
74    variable araw     $config(raw)
75    variable alog     $config(log)
76    variable xttimes {}
77    # alog => !araw
78
79    set shells $config(shells)
80    if {![llength $shells]} {
81	catch {set shells [sak::test::shell::list]}
82    }
83    if {![llength $shells]} {
84	set shells [list [info nameofexecutable]]
85    }
86
87    if {$alog} {
88	variable logext [open $config(stem).log         w]
89	variable logsum [open $config(stem).summary     w]
90	variable logfai [open $config(stem).failures    w]
91	variable logski [open $config(stem).skipped     w]
92	variable lognon [open $config(stem).none        w]
93	variable logerd [open $config(stem).errdetails  w]
94	variable logfad [open $config(stem).faildetails w]
95	# Timings per testsuite (sec), average test timings (usec)
96	variable logtim [open $config(stem).timings     w]
97	variable logtmt [open $config(stem).timetable   w]
98	# Timings per test (usec)
99	variable logtti [open $config(stem).t-timings   w]
100	variable logtmi [open $config(stem).t-timetable w]
101    } else {
102	variable logext stdout
103    }
104
105    # Preprocessing of module names and shell versions to allows
106    # better formatting of the progress output, i.e. vertically
107    # aligned columns
108
109    if {!$araw} {
110	variable maxml 0
111	variable maxvl 0
112	sak::animate::init
113	foreach m $modules {
114	    = "M  $m"
115	    set l [string length $m]
116	    if {$l > $maxml} {set maxml $l}
117	}
118	foreach sh $shells {
119	    = "SH $sh"
120	    set v [exec $sh << {puts [info patchlevel]; exit}]
121	    set l [string length $v]
122	    if {$l > $maxvl} {set maxvl $l}
123	}
124	=| "Starting ..."
125    }
126
127    set total 0
128    set pass  0
129    set fail  0
130    set skip  0
131    set err   0
132
133    foreach sh $shells {
134	foreach m $modules {
135	    set cmd [Command config $m $sh]
136	    sak::animate::init
137	    if {$alog || $araw} {
138		puts  $logext ============================================================
139		flush $logext
140	    }
141	    if {[catch {Close [Process [open |$cmd r+]]} msg]} {
142		incr err
143		=| "~~ [mag]ERR   ${msg}[rst]"
144		if {$alog || $araw} {
145		    puts  $logext [mag]$msg[rst]
146		    flush $logext
147		}
148	    }
149	    #sak::animate::last Ok
150	}
151    }
152
153    puts $logext "Passed  [format %6d $pass] of [format %6d $total]"
154    puts $logext "Skipped [format %6d $skip] of [format %6d $total]"
155
156    if {$fail} {
157	puts $logext "Failed  [red][format %6d $fail][rst] of [format %6d $total]"
158    } else {
159	puts $logext "Failed  [format %6d $fail] of [format %6d $total]"
160    }
161    if {$err} {
162	puts $logext "#Errors [mag][format %6d $err][rst]"
163    } else {
164	puts $logext "#Errors [format %6d $err]"
165    }
166
167    flush $logext
168
169    =| "... Done"
170
171    if {$alog} {
172	# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
173	# Timings per testsuite
174	=| "... Postprocessing per-testsuite timings ..."
175
176	variable xtimes
177
178	struct::matrix M
179	M add columns 6
180
181	M add row {Shell Module Testsuite Tests Seconds uSec/Test}
182	M add row {===== ====== ========= ===== ======= =========}
183
184	foreach item [lsort -decreasing -int -index 3 [lsort -dict -index 0 $xtimes]] {
185	    foreach {k testnum delta score} $item break
186	    M add row [linsert $k end $testnum $delta $score]
187	}
188
189	M add row {===== ====== ========= ===== ======= =========}
190
191	puts $logtmt "\nTiming Table..."
192	puts $logtmt [M format 2string]
193
194	# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
195	# Timings per testcase.
196	=| "... Postprocessing per-test timings ..."
197
198	variable xttimes
199	struct::matrix MX
200	MX add columns 5
201
202	MX add row {Shell Module Testsuite Test uSec}
203	MX add row {===== ====== ========= ==== ====}
204
205	foreach item [lsort -index 1 -integer -decreasing [lsort -index 0 -dict $xttimes]] {
206	    foreach {k usec} $item break
207	    MX add row [linsert $k end $usec]
208	}
209
210	MX add row {===== ====== ========= ==== ====}
211
212	puts $logtmi "\nTiming Table..."
213	puts $logtmi [MX format 2string]
214
215	# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
216	=| "... Postprocessing Done"
217    }
218
219    exit [expr {($err || $fail) ? 1 : 0}]
220    return
221}
222
223# ###
224
225if {$::tcl_platform(platform) == "windows"} {
226
227    proc ::sak::test::run::Command {cv m sh} {
228	variable valgrind
229	upvar 1 $cv config
230
231	# Windows. Construction of the pipe to run a specific
232	# testsuite against a single shell. There is no valgrind to
233	# accomodate, and neither can we expect to have unix commands
234	# like 'echo' and 'cat' available. 'echo' we can go without. A
235	# 'cat' however is needed to merge stdout and stderr of the
236	# testsuite for processing here. We use an emuluation written
237	# in Tcl.
238
239	set catfile cat[pid].tcl
240	fileutil::writeFile $catfile {
241	    catch {wm withdraw .}
242	    while {![eof stdin]} {puts stdout [gets stdin]}
243	    exit
244	}
245
246	set     cmd ""
247	lappend cmd $sh
248	lappend cmd [Driver] -modules [list $m]
249	lappend cmd |& $sh $catfile
250	#puts <<$cmd>>
251
252	return $cmd
253    }
254
255    proc ::sak::test::run::Close {pipe} {
256	close $pipe
257	file delete cat[pid].tcl
258	return
259    }
260} else {
261    proc ::sak::test::run::Command {cv m sh} {
262	variable valgrind
263	upvar 1 $cv config
264
265	# Unix. Construction of the pipe to run a specific testsuite
266	# against a single shell. The command is constructed to work
267	# when using valgrind, and works when not using it as well.
268
269	set     script {}
270	lappend script [list set argv [list -modules [list $m]]]
271	lappend script {set argc 2}
272	lappend script [list source [Driver]]
273	lappend script exit
274
275	set     cmd ""
276	lappend cmd echo [join $script \n]
277	lappend cmd |
278
279	if {$config(valgrind)} {
280	    foreach e $valgrind {lappend cmd $e}
281	    if {$config(valgrind) > 1} {
282		lappend cmd --num-callers=8
283		lappend cmd --leak-resolution=high
284		lappend cmd -v --leak-check=yes
285		lappend cmd --show-reachable=yes
286	    }
287	}
288	lappend cmd $sh
289	#lappend cmd >@ stdout 2>@ stderr
290	lappend cmd |& cat
291	#puts <<$cmd>>
292
293	return $cmd
294    }
295
296    proc ::sak::test::run::Close {pipe} {
297	close $pipe
298	return
299    }
300}
301
302# ###
303
304proc ::sak::test::run::Process {pipe} {
305    variable araw
306    variable alog
307    variable logext
308    while {1} {
309	if {[eof  $pipe]} break
310	if {[gets $pipe line] < 0} break
311	if {$alog || $araw} {puts $logext $line ; flush $logext}
312	set rline $line
313	set line [string trim $line]
314	if {[string equal $line ""]} continue
315	Host;	Platform
316	Cwd;	Shell
317	Tcl
318	Start;	End ; StartFile ; EndFile
319	Module;	Testsuite
320	NoTestsuite
321	Support;Testing;Other
322	Summary
323	CaptureFailureSync            ; # xcollect 1 => 2
324	CaptureFailureCollectBody     ; # xcollect 2 => 3 => 5
325	CaptureFailureCollectActual   ; # xcollect 3 => 4
326	CaptureFailureCollectExpected ; # xcollect 4 => 0
327	CaptureFailureCollectError    ; # xcollect 5 => 0
328	CaptureStackStart
329	CaptureStack
330
331	TestStart
332	TestTook
333	TestSkipped
334	TestPassed
335	TestFailed                    ; # xcollect => 1
336
337	SetupError
338	Aborted
339	AbortCause
340
341	Match||Skip||Sourced
342	# Unknown lines are printed
343	if {!$araw} {puts !$line}
344    }
345    return $pipe
346}
347
348# ###
349
350proc ::sak::test::run::Driver {} {
351    variable base
352    return [file join $base all.tcl]
353}
354
355# ###
356
357proc ::sak::test::run::Host {} {
358    upvar 1 line line ; variable xhost
359    if {![regexp "^@@ Host (.*)$" $line -> xhost]} return
360    # += $xhost
361    set xhost [list Tests Results $xhost]
362    #sak::registry::local set $xhost
363    return -code continue
364}
365
366proc ::sak::test::run::Platform {} {
367    upvar 1 line line ; variable xplatform
368    if {![regexp "^@@ Platform (.*)$" $line -> xplatform]} return
369    # += ($xplatform)
370    variable xhost
371    #sak::registry::local set $xhost Platform $xplatform
372    return -code continue
373}
374
375proc ::sak::test::run::Cwd {} {
376    upvar 1 line line ; variable xcwd
377    if {![regexp "^@@ CWD (.*)$" $line -> xcwd]} return
378    variable xhost
379    set xcwd [linsert $xhost end $xcwd]
380    #sak::registry::local set $xcwd
381    return -code continue
382}
383
384proc ::sak::test::run::Shell {} {
385    upvar 1 line line ; variable xshell
386    if {![regexp "^@@ Shell (.*)$" $line -> xshell]} return
387    # += [file tail $xshell]
388    variable xcwd
389    set xshell [linsert $xcwd end $xshell]
390    #sak::registry::local set $xshell
391    return -code continue
392}
393
394proc ::sak::test::run::Tcl {} {
395    upvar 1 line line ; variable xtcl
396    if {![regexp "^@@ Tcl (.*)$" $line -> xtcl]} return
397    variable xshell
398    variable maxvl
399    += \[$xtcl\][blank [expr {$maxvl - [string length $xtcl]}]]
400    #sak::registry::local set $xshell Tcl $xtcl
401    return -code continue
402}
403
404proc ::sak::test::run::Match||Skip||Sourced {} {
405    upvar 1 line line
406    if {[string match "@@ Skip*"                  $line]} {return -code continue}
407    if {[string match "@@ Match*"                 $line]} {return -code continue}
408    if {[string match "Sourced * Test Files."     $line]} {return -code continue}
409    if {[string match "Files with failing tests*" $line]} {return -code continue}
410    if {[string match "Number of tests skipped*"  $line]} {return -code continue}
411    if {[string match "\[0-9\]*"                  $line]} {return -code continue}
412    return
413}
414
415proc ::sak::test::run::Start {} {
416    upvar 1 line line
417    if {![regexp "^@@ Start (.*)$" $line -> start]} return
418    variable xshell
419    #sak::registry::local set $xshell Start $start
420    return -code continue
421}
422
423proc ::sak::test::run::End {} {
424    upvar 1 line line
425    if {![regexp "^@@ End (.*)$" $line -> end]} return
426    variable xshell
427    #sak::registry::local set $xshell End $end
428    return -code continue
429}
430
431proc ::sak::test::run::StartFile {} {
432    upvar 1 line line
433    if {![regexp "^@@ StartFile (.*)$" $line -> start]} return
434    variable xstartfile $start
435    variable xtestnum 0
436    #sak::registry::local set $xshell Start $start
437    return -code continue
438}
439
440proc ::sak::test::run::EndFile {} {
441    upvar 1 line line
442    if {![regexp "^@@ EndFile (.*)$" $line -> end]} return
443    variable xfile
444    variable xstartfile
445    variable xtimes
446    variable xtestnum
447    variable xduration
448
449    set k [lreplace $xfile 0 3]
450    set k [lreplace $k 2 2 [file tail [lindex $k 2]]]
451    set delta [expr {$end - $xstartfile}]
452    incr xduration $delta
453
454    if {$xtestnum == 0} {
455	set score $delta
456    } else {
457	# average number of microseconds per test.
458	set score [expr {int(($delta/double($xtestnum))*1000000)}]
459	#set score [expr {$delta/double($xtestnum)}]
460    }
461
462    lappend xtimes [list $k $xtestnum $delta $score]
463
464    variable alog
465    if {$alog} {
466	variable logtim
467	puts $logtim [linsert [linsert $k end $xtestnum $delta $score] 0 TIME]
468    }
469
470    #sak::registry::local set $xshell End $end
471    return -code continue
472}
473
474proc ::sak::test::run::Module {} {
475    upvar 1 line line ; variable xmodule
476    if {![regexp "^@@ Module (.*)$" $line -> xmodule]} return
477    variable xshell
478    variable xstatus ok
479    variable maxml
480    variable xduration 0
481    += ${xmodule}[blank [expr {$maxml - [string length $xmodule]}]]
482    set xmodule [linsert $xshell end $xmodule]
483    #sak::registry::local set $xmodule
484    return -code continue
485}
486
487proc ::sak::test::run::Testsuite {} {
488    upvar 1 line line ; variable xfile
489    if {![regexp "^@@ Testsuite (.*)$" $line -> xfile]} return
490    = <[file tail $xfile]>
491    variable xmodule
492    set xfile [linsert $xmodule end $xfile]
493    #sak::registry::local set $xfile Aborted 0
494    return -code continue
495}
496
497proc ::sak::test::run::NoTestsuite {} {
498    upvar 1 line line
499    if {![string match "Error:  No test files remain after*" $line]} return
500    variable xstatus none
501    = {No tests}
502    return -code continue
503}
504
505proc ::sak::test::run::Support {} {
506    upvar 1 line line
507    if {![regexp "^- (.*)$" $line -> package]} return
508    #= "S $package"
509    foreach {pn pv} $package break
510    variable xfile
511    #sak::registry::local set [linsert $xfile end Support] $pn $pv
512    return -code continue
513}
514
515proc ::sak::test::run::Testing {} {
516    upvar 1 line line
517    if {![regexp "^\\* (.*)$" $line -> package]} return
518    #= "T $package"
519    foreach {pn pv} $package break
520    variable xfile
521    #sak::registry::local set [linsert $xfile end Testing] $pn $pv
522    return -code continue
523}
524
525proc ::sak::test::run::Other {} {
526    upvar 1 line line
527    if {![string match ">*" $line]} return
528    return -code continue
529}
530
531proc ::sak::test::run::Summary {} {
532    upvar 1 line line
533    if {![regexp "^all\\.tcl:(.*)$" $line -> line]} return
534    variable xmodule
535    variable xstatus
536    variable xvstatus
537
538    foreach {_ t _ p _ s _ f} [split [string trim $line]] break
539    #sak::registry::local set $xmodule Total   $t ; set t [format %5d $t]
540    #sak::registry::local set $xmodule Passed  $p ; set p [format %5d $p]
541    #sak::registry::local set $xmodule Skipped $s ; set s [format %5d $s]
542    #sak::registry::local set $xmodule Failed  $f ; set f [format %5d $f]
543
544    upvar 2 total _total ; incr _total $t
545    upvar 2 pass  _pass  ; incr _pass  $p
546    upvar 2 skip  _skip  ; incr _skip  $s
547    upvar 2 fail  _fail  ; incr _fail  $f
548    upvar 2 err   _err
549
550    set t [format %5d $t]
551    set p [format %5d $p]
552    set s [format %5d $s]
553    set f [format %5d $f]
554
555    if {$xstatus == "ok" && $t == 0} {
556	set xstatus none
557	set spent ""
558    } else {
559	# Time spent on all the files in the module.
560	variable xduration
561	#set sec $xduration
562	#set min [expr {$sec / 60}]
563	#set sec [expr {$sec % 60}]
564	#set hor [expr {$min / 60}]
565	#set min [expr {$min % 60}]
566	#set spent " :[format %02d $hor]h[format %02d $min]m[format %02d $sec]s"
567	set spent " @${xduration}s"
568    }
569
570    set st $xvstatus($xstatus)
571
572    if {$xstatus == "ok"} {
573	# Quick return for ok suite.
574	=| "~~ $st T $t P $p S $s F $f$spent"
575	return -code continue
576    }
577
578    # Clean out progress display using a non-highlighted
579    # string. Prevents the char count from being off. This is
580    # followed by construction and display of the highlighted version.
581
582    = "   $st T $t P $p S $s F $f$spent"
583    switch -exact -- $xstatus {
584	none    {=| "~~ [yel]$st T $t[rst] P $p S $s F $f"}
585	aborted {=| "~~ [whi]$st[rst] T $t P $p S $s F $f$spent"}
586	error   {=| "~~ [mag]$st[rst] T $t P $p S $s F $f$spent" ; incr _err }
587	fail    {=| "~~ [red]$st[rst] T $t P $p S $s [red]F $f[rst]$spent"}
588    }
589    return -code continue
590}
591
592proc ::sak::test::run::TestStart {} {
593    upvar 1 line line
594    if {![string match {---- * start} $line]} return
595    set testname [string range $line 5 end-6]
596    = "---- $testname"
597    variable xfile
598    variable xtesttime -1
599    variable xtest [linsert $xfile end $testname]
600    variable xtestnum
601    incr     xtestnum
602    return -code continue
603}
604
605proc ::sak::test::run::TestTook {} {
606    upvar 1 line line
607    if {![string match {++++ * took *} $line]} return
608    # Dynamic search for the marker because the name of the test may
609    # contain spaces, causing the field position to vary.
610    set  pos [lsearch -exact $line took]
611    incr pos
612    set usec [lindex $line $pos]
613    variable xtesttime $usec
614    return -code continue
615}
616
617proc ::sak::test::run::TestSkipped {} {
618    upvar 1 line line
619    if {![string match {++++ * SKIPPED:*} $line]} return
620    regexp {^[^ ]* (.*)SKIPPED:.*$} $line -> testname
621    set              testname [string trim $testname]
622    variable xtest
623    = "SKIP $testname"
624    if {$xtest == {}} {
625	variable xfile
626	set xtest [linsert $xfile end $testname]
627    }
628    #sak::registry::local set $xtest Status Skip
629    set xtest {}
630    return -code continue
631}
632
633proc ::sak::test::run::TestPassed {} {
634    upvar 1 line line
635    if {![string match {++++ * PASSED} $line]} return
636    set             testname [string range $line 5 end-7]
637    variable xtesttime
638    variable xtest
639    if {$xtesttime < 0} { set xtesttime "" }
640    = [string trimright "PASS $testname $xtesttime"]
641    if {$xtest == {}} {
642	variable xfile
643	set xtest [linsert $xfile end $testname]
644    }
645    #sak::registry::local set $xtest Status Pass
646    variable alog
647    if {$alog && ($xtesttime ne {})} {
648	variable xttimes
649	variable logtti
650	set k [lreplace $xtest 0 3]
651	set k [lreplace $k 2 2 [file tail [lindex $k 2]]]
652	# k = shell module testfile testname
653	puts $logtti [linsert [linsert $k 0 TIME] end $xtesttime]
654
655	lappend xttimes [list $k $xtesttime]
656    }
657    set xtest {}
658    return -code continue
659}
660
661proc ::sak::test::run::TestFailed {} {
662    upvar 1 line line
663    if {![string match {==== * FAILED} $line]} return
664    set        testname [lindex [split [string range $line 5 end-7]] 0]
665    = "FAIL $testname"
666    variable xtest
667    if {$xtest == {}} {
668	variable xfile
669	set xtest [linsert $xfile end $testname]
670    }
671    #sak::registry::local set $xtest Status Fail
672    ## CAPTURE INIT
673    variable xcollect  1
674    variable xbody     ""
675    variable xactual   ""
676    variable xexpected ""
677    variable xstatus   fail
678    # Ignore failed status if we already have it, or an error
679    # status. The latter is more important to show. We do override
680    # status 'aborted'.
681    if {$xstatus == "ok"}      {set xstatus fail}
682    if {$xstatus == "aborted"} {set xstatus fail}
683    return -code continue
684}
685
686proc ::sak::test::run::CaptureFailureSync {} {
687    variable xcollect
688    if {$xcollect != 1} return
689    upvar 1 line line
690    if {![string match {==== Contents*} $line]} return
691    set xcollect 2
692    return -code continue
693}
694
695proc ::sak::test::run::CaptureFailureCollectBody {} {
696    variable xcollect
697    if {$xcollect != 2} return
698    upvar 1 rline line
699    variable xbody
700    if {[string match {---- Result was*} $line]} {
701	set xcollect 3
702	return -code continue
703    } elseif {[string match {---- Test generated error*} $line]} {
704	set xcollect 5
705	return -code continue
706    }
707
708    variable xbody
709    append   xbody $line \n
710    return -code continue
711}
712
713proc ::sak::test::run::CaptureFailureCollectActual {} {
714    variable xcollect
715    if {$xcollect != 3} return
716    upvar 1 rline line
717    if {![string match {---- Result should*} $line]} {
718	variable xactual
719	append   xactual $line \n
720    } else {
721	set xcollect 4
722    }
723    return -code continue
724}
725
726proc ::sak::test::run::CaptureFailureCollectExpected {} {
727    variable xcollect
728    if {$xcollect != 4} return
729    upvar 1 rline line
730    if {![string match {==== *} $line]} {
731	variable xexpected
732	append   xexpected $line \n
733    } else {
734	variable alog
735	if {$alog} {
736	    variable logfad
737	    variable xtest
738	    variable xbody
739	    variable xactual
740	    variable xexpected
741
742	    puts  $logfad "==== [lrange $xtest end-1 end] FAILED ========="
743	    puts  $logfad "==== Contents of test case:\n"
744	    puts  $logfad $xbody
745
746	    puts  $logfad "---- Result was:"
747	    puts  $logfad [string range $xactual 0 end-1]
748
749	    puts  $logfad "---- Result should have been:"
750	    puts  $logfad [string range $xexpected 0 end-1]
751
752	    puts  $logfad "==== [lrange $xtest end-1 end] ====\n\n"
753	    flush $logfad
754	}
755	set xcollect 0
756	#sak::registry::local set $xtest Body     $xbody
757	#sak::registry::local set $xtest Actual   $xactual
758	#sak::registry::local set $xtest Expected $xexpected
759	set xtest {}
760    }
761    return -code continue
762}
763
764proc ::sak::test::run::CaptureFailureCollectError {} {
765    variable xcollect
766    if {$xcollect != 5} return
767    upvar 1 rline line
768    variable xbody
769    if {[string match {---- errorCode*} $line]} {
770	set xcollect 4
771	return -code continue
772    }
773
774    variable xactual
775    append   xactual $line \n
776    return -code continue
777}
778
779proc ::sak::test::run::Aborted {} {
780    upvar 1 line line
781    if {![string match {Aborting the tests found *} $line]} return
782    variable xfile
783    variable xstatus
784    # Ignore aborted status if we already have it, or some other error
785    # status (like error, or fail). These are more important to show.
786    if {$xstatus == "ok"} {set xstatus aborted}
787    = Aborted
788    #sak::registry::local set $xfile Aborted {}
789    return -code continue
790}
791
792proc ::sak::test::run::AbortCause {} {
793    upvar 1 line line
794    if {
795	![string match {Requiring *} $line] &&
796	![string match {Error in *} $line]
797    } return ; # {}
798    variable xfile
799    = $line
800    #sak::registry::local set $xfile Aborted $line
801    return -code continue
802}
803
804proc ::sak::test::run::CaptureStackStart {} {
805    upvar 1 line line
806    if {![string match {@+*} $line]} return
807    variable xstackcollect 1
808    variable xstack        {}
809    variable xstatus       error
810    = {Error, capturing stacktrace}
811    return -code continue
812}
813
814proc ::sak::test::run::CaptureStack {} {
815    variable xstackcollect
816    if {!$xstackcollect} return
817    upvar 1 line line
818    variable xstack
819    if {![string match {@-*} $line]} {
820	append xstack [string range $line 2 end] \n
821    } else {
822	set xstackcollect 0
823	variable xfile
824	variable alog
825	#sak::registry::local set $xfile Stacktrace $xstack
826	if {$alog} {
827	    variable logerd
828	    puts  $logerd "[lindex $xfile end] StackTrace"
829	    puts  $logerd "========================================"
830	    puts  $logerd $xstack
831	    puts  $logerd "========================================\n\n"
832	    flush $logerd
833	}
834    }
835    return -code continue
836}
837
838proc ::sak::test::run::SetupError {} {
839    upvar 1 line line
840    if {![string match {SETUP Error*} $line]} return
841    variable xstatus error
842    = {Setup error}
843    return -code continue
844}
845
846# ###
847
848proc ::sak::test::run::+= {string} {
849    variable araw
850    if {$araw} return
851    variable aprefix
852    append   aprefix " " $string
853    sak::animate::next $aprefix
854    return
855}
856
857proc ::sak::test::run::= {string} {
858    variable araw
859    if {$araw} return
860    variable aprefix
861    sak::animate::next "$aprefix $string"
862    return
863}
864
865proc ::sak::test::run::=| {string} {
866    variable araw
867    if {$araw} return
868    variable aprefix
869    sak::animate::last "$aprefix $string"
870    variable alog
871    if {$alog} {
872	variable logsum
873	variable logfai
874	variable logski
875	variable lognon
876	variable xstatus
877	puts $logsum "$aprefix $string" ; flush $logsum
878	switch -exact -- $xstatus {
879	    error   -
880	    fail    {puts $logfai "$aprefix $string" ; flush $logfai}
881	    none    {puts $lognon "$aprefix $string" ; flush $lognon}
882	    aborted {puts $logski "$aprefix $string" ; flush $logski}
883	}
884    }
885    set aprefix ""
886    return
887}
888
889# ###
890
891namespace eval ::sak::test::run {
892    variable base     [file join $::distribution support devel]
893    variable valgrind [auto_execok valgrind]
894
895    # State of test processing.
896
897    variable xstackcollect 0
898    variable xstack    {}
899    variable xcollect  0
900    variable xbody     {}
901    variable xactual   {}
902    variable xexpected {}
903    variable xhost     {}
904    variable xplatform {}
905    variable xcwd      {}
906    variable xshell    {}
907    variable xmodule   {}
908    variable xfile     {}
909    variable xtest     {}
910    variable xstartfile {}
911    variable xtimes     {}
912
913    variable xstatus ok
914
915    # Animation prefix of test processing, and flag controlling the
916    # nature of logging (raw vs animation).
917
918    variable aprefix   {}
919    variable araw      0
920
921    # Max length of module names and patchlevel information.
922
923    variable maxml 0
924    variable maxvl 0
925
926    # Map from internal stati to the displayed human readable
927    # strings. This includes the trailing whitespace needed for
928    # vertical alignment.
929
930    variable  xvstatus
931    array set xvstatus {
932	ok      {     }
933	none    {None }
934	aborted {Skip }
935	error   {ERR  }
936	fail    {FAILS}
937    }
938}
939
940##
941# ###
942
943package provide sak::test::run 1.0
944
945if 0 {
946    # Bad valgrind, ok no valgrind
947    if {$config(valgrind)} {
948	foreach e $valgrind {lappend cmd $e}
949	lappend cmd --num-callers=8
950	lappend cmd --leak-resolution=high
951	lappend cmd -v --leak-check=yes
952	lappend cmd --show-reachable=yes
953    }
954    lappend cmd $sh
955    lappend cmd [Driver] -modules $modules
956}
957