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
14
15namespace eval ::sak::test::run {
16    namespace import ::textutil::repeat::blank
17    namespace import ::sak::color::*
18}
19
20# ###
21
22proc ::sak::test::run {argv} {
23    variable run::valgrind
24    array set config {
25	valgrind 0 raw 0 shells {} stem {} log 0
26    }
27
28    while {[string match -* [set opt [lindex $argv 0]]]} {
29	switch -exact -- $opt {
30	    -s - --shell {
31		set sh [lindex $argv 1]
32		if {![fileutil::test $sh efrx msg "Shell"]} {
33		    sak::test::usage $msg
34		}
35		lappend config(shells) $sh
36		set argv [lrange $argv 2 end]
37	    }
38	    -g - --valgrind {
39		if {![llength $valgrind]} {
40		    sak::test::usage valgrind not found in the PATH
41		}
42		incr config(valgrind)
43		set argv [lrange $argv 1 end]
44	    }
45	    -v {
46		set config(raw) 1
47		set argv [lrange $argv 1 end]
48	    }
49	    -l - --log {
50		set config(log) 1
51		set config(stem) [lindex $argv 1]
52		set argv         [lrange $argv 2 end]
53	    }
54	    default {
55		sak::test::usage Unknown option "\"$opt\""
56	    }
57	}
58    }
59
60    if {$config(log)} {set config(raw) 0}
61
62    if {![sak::util::checkModules argv]} return
63
64    run::Do config $argv
65    return
66}
67
68# ###
69
70proc ::sak::test::run::Do {cv modules} {
71    upvar 1 $cv config
72    variable valgrind
73    variable araw     $config(raw)
74    variable alog     $config(log)
75    # alog => !araw
76
77    set shells $config(shells)
78    if {![llength $shells]} {
79	catch {set shells [sak::test::shell::list]}
80    }
81    if {![llength $shells]} {
82	set shells [list [info nameofexecutable]]
83    }
84
85    if {$alog} {
86	variable logext [open $config(stem).log      w]
87	variable logsum [open $config(stem).summary  w]
88	variable logfai [open $config(stem).failures w]
89	variable logski [open $config(stem).skipped  w]
90	variable lognon [open $config(stem).none     w]
91    } else {
92	variable logext stdout
93    }
94
95    # Preprocessing of module names and shell versions to allows
96    # better formatting of the progress output, i.e. vertically
97    # aligned columns
98
99    if {!$araw} {
100	variable maxml 0
101	variable maxvl 0
102	sak::animate::init
103	foreach m $modules {
104	    = "M  $m"
105	    set l [string length $m]
106	    if {$l > $maxml} {set maxml $l}
107	}
108	foreach sh $shells {
109	    = "SH $sh"
110	    set v [exec $sh << {puts [info patchlevel]; exit}]
111	    set l [string length $v]
112	    if {$l > $maxvl} {set maxvl $l}
113	}
114	=| "Starting ..."
115    }
116
117    set total 0
118    set pass  0
119    set fail  0
120    set skip  0
121    set err   0
122
123    foreach sh $shells {
124	foreach m $modules {
125	    set cmd [Command config $m $sh]
126	    sak::animate::init
127	    if {$alog || $araw} {
128		puts  $logext ============================================================
129		flush $logext
130	    }
131	    if {[catch {Close [Process [open |$cmd r+]]} msg]} {
132		incr err
133		=| "~~ [mag]ERR   ${msg}[rst]"
134		if {$alog || $araw} {
135		    puts  $logext [mag]$msg[rst]
136		    flush $logext
137		}
138	    }
139	    #sak::animate::last Ok
140	}
141    }
142
143    puts $logext "Passed  [format %6d $pass] of [format %6d $total]"
144    puts $logext "Skipped [format %6d $skip] of [format %6d $total]"
145
146    if {$fail} {
147	puts $logext "Failed  [red][format %6d $fail][rst] of [format %6d $total]"
148    } else {
149	puts $logext "Failed  [format %6d $fail] of [format %6d $total]"
150    }
151    if {$err} {
152	puts $logext "#Errors [mag][format %6d $err][rst]"
153    } else {
154	puts $logext "#Errors [format %6d $err]"
155    }
156
157    exit [expr {($err || $fail) ? 1 : 0}]
158    return
159}
160
161# ###
162
163if {$::tcl_platform(platform) == "windows"} {
164
165    proc ::sak::test::run::Command {cv m sh} {
166	variable valgrind
167	upvar 1 $cv config
168
169	# Windows. Construction of the pipe to run a specific
170	# testsuite against a single shell. There is no valgrind to
171	# accomodate, and neither can we expect to have unix commands
172	# like 'echo' and 'cat' available. 'echo' we can go without. A
173	# 'cat' however is needed to merge stdout and stderr of the
174	# testsuite for processing here. We use an emuluation written
175	# in Tcl.
176
177	set catfile cat[pid].tcl
178	fileutil::writeFile $catfile {
179	    catch {wm withdraw .}
180	    while {![eof stdin]} {puts stdout [gets stdin]}
181	    exit
182	}
183
184	set     cmd ""
185	lappend cmd $sh
186	lappend cmd [Driver] -modules [list $m]
187	lappend cmd |& $sh $catfile
188	#puts <<$cmd>>
189
190	return $cmd
191    }
192
193    proc ::sak::test::run::Close {pipe} {
194	close $pipe
195	file delete cat[pid].tcl
196	return
197    }
198} else {
199    proc ::sak::test::run::Command {cv m sh} {
200	variable valgrind
201	upvar 1 $cv config
202
203	# Unix. Construction of the pipe to run a specific testsuite
204	# against a single shell. The command is constructed to work
205	# when using valgrind, and works when not using it as well.
206
207	set     script {}
208	lappend script [list set argv [list -modules [list $m]]]
209	lappend script {set argc 2}
210	lappend script [list source [Driver]]
211	lappend script exit
212
213	set     cmd ""
214	lappend cmd echo [join $script \n]
215	lappend cmd |
216
217	if {$config(valgrind)} {
218	    foreach e $valgrind {lappend cmd $e}
219	    if {$config(valgrind) > 1} {
220		lappend cmd --num-callers=8
221		lappend cmd --leak-resolution=high
222		lappend cmd -v --leak-check=yes
223		lappend cmd --show-reachable=yes
224	    }
225	}
226	lappend cmd $sh
227	#lappend cmd >@ stdout 2>@ stderr
228	lappend cmd |& cat
229	#puts <<$cmd>>
230
231	return $cmd
232    }
233
234    proc ::sak::test::run::Close {pipe} {
235	close $pipe
236	return
237    }
238}
239
240# ###
241
242proc ::sak::test::run::Process {pipe} {
243    variable araw
244    variable alog
245    variable logext
246    while {1} {
247	if {[eof  $pipe]} break
248	if {[gets $pipe line] < 0} break
249	if {$alog || $araw} {puts $logext $line ; flush $logext}
250	set line [string trim $line]
251	if {[string equal $line ""]} continue
252	Host;	Platform
253	Cwd;	Shell
254	Tcl;	Match||Skip||Sourced
255	Start;	End
256	Module;	Testsuite
257	NoTestsuite
258	Support;Testing;Other
259	Summary
260
261	TestStart
262	TestSkipped
263	TestPassed
264	TestFailed
265	CaptureFailureSync
266	CaptureFailureCollectBody
267	CaptureFailureCollectActual
268	CaptureFailureCollectExpected
269	CaptureStackStart
270	CaptureStack
271
272	SetupError
273	Aborted
274	AbortCause
275
276	# Unknown lines are printed
277	if {!$araw} {puts !$line}
278    }
279    return $pipe
280}
281
282# ###
283
284proc ::sak::test::run::Driver {} {
285    variable base
286    return [file join $base all.tcl]
287}
288
289# ###
290
291proc ::sak::test::run::Host {} {
292    upvar 1 line line ; variable xhost
293    if {![regexp "^@@ Host (.*)$" $line -> xhost]} return
294    # += $xhost
295    set xhost [list Tests Results $xhost]
296    #sak::registry::local set $xhost
297    return -code continue
298}
299
300proc ::sak::test::run::Platform {} {
301    upvar 1 line line ; variable xplatform
302    if {![regexp "^@@ Platform (.*)$" $line -> xplatform]} return
303    # += ($xplatform)
304    variable xhost
305    #sak::registry::local set $xhost Platform $xplatform
306    return -code continue
307}
308
309proc ::sak::test::run::Cwd {} {
310    upvar 1 line line ; variable xcwd
311    if {![regexp "^@@ CWD (.*)$" $line -> xcwd]} return
312    variable xhost
313    set xcwd [linsert $xhost end $xcwd]
314    #sak::registry::local set $xcwd
315    return -code continue
316}
317
318proc ::sak::test::run::Shell {} {
319    upvar 1 line line ; variable xshell
320    if {![regexp "^@@ Shell (.*)$" $line -> xshell]} return
321    # += [file tail $xshell]
322    variable xcwd
323    set xshell [linsert $xcwd end $xshell]
324    #sak::registry::local set $xshell
325    return -code continue
326}
327
328proc ::sak::test::run::Tcl {} {
329    upvar 1 line line ; variable xtcl
330    if {![regexp "^@@ Tcl (.*)$" $line -> xtcl]} return
331    variable xshell
332    variable maxvl
333    += \[$xtcl\][blank [expr {$maxvl - [string length $xtcl]}]]
334    #sak::registry::local set $xshell Tcl $xtcl
335    return -code continue
336}
337
338proc ::sak::test::run::Match||Skip||Sourced {} {
339    upvar 1 line line
340    if {[string match "@@ Skip*"                  $line]} {return -code continue}
341    if {[string match "@@ Match*"                 $line]} {return -code continue}
342    if {[string match "Sourced * Test Files."     $line]} {return -code continue}
343    if {[string match "Files with failing tests*" $line]} {return -code continue}
344    if {[string match "Number of tests skipped*"  $line]} {return -code continue}
345    if {[string match "\[0-9\]*"                  $line]} {return -code continue}
346    return
347}
348
349proc ::sak::test::run::Start {} {
350    upvar 1 line line
351    if {![regexp "^@@ Start (.*)$" $line -> start]} return
352    variable xshell
353    #sak::registry::local set $xshell Start $start
354    return -code continue
355}
356
357proc ::sak::test::run::End {} {
358    upvar 1 line line
359    if {![regexp "^@@ End (.*)$" $line -> end]} return
360    variable xshell
361    #sak::registry::local set $xshell End $end
362    return -code continue
363}
364
365proc ::sak::test::run::Module {} {
366    upvar 1 line line ; variable xmodule
367    if {![regexp "^@@ Module (.*)$" $line -> xmodule]} return
368    variable xshell
369    variable xstatus ok
370    variable maxml
371    += ${xmodule}[blank [expr {$maxml - [string length $xmodule]}]]
372    set xmodule [linsert $xshell end $xmodule]
373    #sak::registry::local set $xmodule
374    return -code continue
375}
376
377proc ::sak::test::run::Testsuite {} {
378    upvar 1 line line ; variable xfile
379    if {![regexp "^@@ Testsuite (.*)$" $line -> xfile]} return
380    = <[file tail $xfile]>
381    variable xmodule
382    set xfile [linsert $xmodule end $xfile]
383    #sak::registry::local set $xfile Aborted 0
384    return -code continue
385}
386
387proc ::sak::test::run::NoTestsuite {} {
388    upvar 1 line line
389    if {![string match "Error:  No test files remain after*" $line]} return
390    variable xstatus none
391    = {No tests}
392    return -code continue
393}
394
395proc ::sak::test::run::Support {} {
396    upvar 1 line line
397    if {![regexp "^- (.*)$" $line -> package]} return
398    #= "S $package"
399    foreach {pn pv} $package break
400    variable xfile
401    #sak::registry::local set [linsert $xfile end Support] $pn $pv
402    return -code continue
403}
404
405proc ::sak::test::run::Testing {} {
406    upvar 1 line line
407    if {![regexp "^\\* (.*)$" $line -> package]} return
408    #= "T $package"
409    foreach {pn pv} $package break
410    variable xfile
411    #sak::registry::local set [linsert $xfile end Testing] $pn $pv
412    return -code continue
413}
414
415proc ::sak::test::run::Other {} {
416    upvar 1 line line
417    if {![string match ">*" $line]} return
418    return -code continue
419}
420
421proc ::sak::test::run::Summary {} {
422    upvar 1 line line
423    if {![regexp "^all\\.tcl:(.*)$" $line -> line]} return
424    variable xmodule
425    variable xstatus
426    variable xvstatus
427    foreach {_ t _ p _ s _ f} [split [string trim $line]] break
428    #sak::registry::local set $xmodule Total   $t ; set t [format %5d $t]
429    #sak::registry::local set $xmodule Passed  $p ; set p [format %5d $p]
430    #sak::registry::local set $xmodule Skipped $s ; set s [format %5d $s]
431    #sak::registry::local set $xmodule Failed  $f ; set f [format %5d $f]
432
433    upvar 2 total _total ; incr _total $t
434    upvar 2 pass  _pass  ; incr _pass  $p
435    upvar 2 skip  _skip  ; incr _skip  $s
436    upvar 2 fail  _fail  ; incr _fail  $f
437    upvar 2 err   _err
438
439    set t [format %5d $t]
440    set p [format %5d $p]
441    set s [format %5d $s]
442    set f [format %5d $f]
443
444    if {$xstatus == "ok" && $t == 0} {
445	set xstatus none
446    }
447
448    set st $xvstatus($xstatus)
449
450    if {$xstatus == "ok"} {
451	# Quick return for ok suite.
452	=| "~~ $st T $t P $p S $s F $f"
453	return -code continue
454    }
455
456    # Clean out progress display using a non-highlighted
457    # string. Prevents the char couint from being off. This is
458    # followed by construction and display of the highlighted version.
459
460    = "   $st T $t P $p S $s F $f"
461    switch -exact -- $xstatus {
462	none    {=| "~~ [yel]$st T $t[rst] P $p S $s F $f"}
463	aborted {=| "~~ [whi]$st[rst] T $t P $p S $s F $f"}
464	error   {
465	    =| "~~ [mag]$st[rst] T $t P $p S $s F $f"
466	    incr _err
467	}
468	fail    {=| "~~ [red]$st[rst] T $t P $p S $s [red]F $f[rst]"}
469    }
470    return -code continue
471}
472
473proc ::sak::test::run::TestStart {} {
474    upvar 1 line line
475    if {![string match {---- * start} $line]} return
476    set testname [string range $line 5 end-6]
477    = "---- $testname"
478    variable xfile
479    variable xtest [linsert $xfile end $testname]
480    return -code continue
481}
482
483proc ::sak::test::run::TestSkipped {} {
484    upvar 1 line line
485    if {![string match {++++ * SKIPPED:*} $line]} return
486    regexp {^[^ ]* (.*)SKIPPED:.*$} $line -> testname
487    set              testname [string trim $testname]
488    variable xtest
489    = "SKIP $testname"
490    if {$xtest == {}} {
491	variable xfile
492	set xtest [linsert $xfile end $testname]
493    }
494    #sak::registry::local set $xtest Status Skip
495    set xtest {}
496    return -code continue
497}
498
499proc ::sak::test::run::TestPassed {} {
500    upvar 1 line line
501    if {![string match {++++ * PASSED} $line]} return
502    set             testname [string range $line 5 end-7]
503    variable xtest
504    = "PASS $testname"
505    if {$xtest == {}} {
506	variable xfile
507	set xtest [linsert $xfile end $testname]
508    }
509    #sak::registry::local set $xtest Status Pass
510    set xtest {}
511    return -code continue
512}
513
514proc ::sak::test::run::TestFailed {} {
515    upvar 1 line line
516    if {![string match {==== * FAILED} $line]} return
517    set        testname [lindex [split [string range $line 5 end-7]] 0]
518    = "FAIL $testname"
519    variable xtest
520    if {$xtest == {}} {
521	variable xfile
522	set xtest [linsert $xfile end $testname]
523    }
524    #sak::registry::local set $xtest Status Fail
525    ## CAPTURE INIT
526    variable xcollect  1
527    variable xbody     ""
528    variable xactual   ""
529    variable xexpected ""
530    variable xstatus   fail
531    # Ignore failed status if we already have it, or an error
532    # status. The latter is more important to show. We do override
533    # status 'aborted'.
534    if {$xstatus == "ok"}      {set xstatus fail}
535    if {$xstatus == "aborted"} {set xstatus fail}
536    return -code continue
537}
538
539proc ::sak::test::run::CaptureFailureSync {} {
540    variable xcollect
541    if {$xcollect != 1} return
542    upvar 1 line line
543    if {![string match {==== Contents*} $line]} return
544    set xcollect 2
545    return -code continue
546}
547
548proc ::sak::test::run::CaptureFailureCollectBody {} {
549    variable xcollect
550    if {$xcollect != 2} return
551    upvar 1 line line
552    variable xbody
553    if {![string match {---- Result was*} $line]} {
554	variable xbody
555	append   xbody $line \n
556    } else {
557	set xcollect 3
558    }
559    return -code continue
560}
561
562proc ::sak::test::run::CaptureFailureCollectActual {} {
563    variable xcollect
564    if {$xcollect != 3} return
565    upvar 1 line line
566    if {![string match {---- Result should*} $line]} {
567	variable xactual
568	append   xactual $line \n
569    } else {
570	set xcollect 4
571    }
572    return -code continue
573}
574
575proc ::sak::test::run::CaptureFailureCollectExpected {} {
576    variable xcollect
577    if {$xcollect != 4} return
578    upvar 1 line line
579    if {![string match {==== *} $line]} {
580	variable xexpected
581	append   xexpected $line \n
582    } else {
583	set xcollect 0
584	#sak::registry::local set $xtest Body     $xbody
585	#sak::registry::local set $xtest Actual   $xactual
586	#sak::registry::local set $xtest Expected $xexpected
587	set xtest {}
588    }
589    return -code continue
590}
591
592proc ::sak::test::run::Aborted {} {
593    upvar 1 line line
594    if {![string match {Aborting the tests found *} $line]} return
595    variable xfile
596    variable xstatus
597    # Ignore aborted status if we already have it, or some other error
598    # status (like error, or fail). These are more important to show.
599    if {$xstatus == "ok"} {set xstatus aborted}
600    = Aborted
601    #sak::registry::local set $xfile Aborted {}
602    return -code continue
603}
604
605proc ::sak::test::run::AbortCause {} {
606    upvar 1 line line
607    if {
608	![string match {Requiring *} $line] &&
609	![string match {Error in *} $line]
610    } return ; # {}
611    variable xfile
612    = $line
613    #sak::registry::local set $xfile Aborted $line
614    return -code continue
615}
616
617proc ::sak::test::run::CaptureStackStart {} {
618    upvar 1 line line
619    if {![string match {@+*} $line]} return
620    variable xstackcollect 1
621    variable xstack        {}
622    variable xstatus       error
623    = {Error, capturing stacktrace}
624    return -code continue
625}
626
627proc ::sak::test::run::CaptureStack {} {
628    variable xstackcollect
629    if {!$xstackcollect} return
630    upvar 1 line line
631    variable xstack
632    if {![string match {@-*} $line]} {
633	append xstack [string range $line 2 end] \n
634    } else {
635	set xstackcollect 0
636	variable xfile
637	#sak::registry::local set $xfile Stacktrace $xstack
638    }
639    return -code continue
640}
641
642proc ::sak::test::run::SetupError {} {
643    upvar 1 line line
644    if {![string match {SETUP Error*} $line]} return
645    variable xstatus error
646    = {Setup error}
647    return -code continue
648}
649
650# ###
651
652proc ::sak::test::run::+= {string} {
653    variable araw
654    if {$araw} return
655    variable aprefix
656    append   aprefix " " $string
657    sak::animate::next $aprefix
658    return
659}
660
661proc ::sak::test::run::= {string} {
662    variable araw
663    if {$araw} return
664    variable aprefix
665    sak::animate::next "$aprefix $string"
666    return
667}
668
669proc ::sak::test::run::=| {string} {
670    variable araw
671    if {$araw} return
672    variable aprefix
673    sak::animate::last "$aprefix $string"
674    variable alog
675    if {$alog} {
676	variable logsum
677	variable logfai
678	variable logski
679	variable lognon
680	variable xstatus
681	puts $logsum "$aprefix $string" ; flush $logsum
682	switch -exact -- $xstatus {
683	    error   -
684	    fail    {puts $logfai "$aprefix $string" ; flush $logfai}
685	    none    {puts $lognon "$aprefix $string" ; flush $lognon}
686	    aborted {puts $logski "$aprefix $string" ; flush $logski}
687	}
688    }
689    set aprefix ""
690    return
691}
692
693# ###
694
695namespace eval ::sak::test::run {
696    variable base     [file join $::distribution support devel]
697    variable valgrind [auto_execok valgrind]
698
699    # State of test processing.
700
701    variable xstackcollect 0
702    variable xstack    {}
703    variable xcollect  0
704    variable xbody     {}
705    variable xactual   {}
706    variable xexpected {}
707    variable xhost     {}
708    variable xplatform {}
709    variable xcwd      {}
710    variable xshell    {}
711    variable xmodule   {}
712    variable xfile     {}
713    variable xtest     {}
714
715    variable xstatus ok
716
717    # Animation prefix of test processing, and flag controlling the
718    # nature of logging (raw vs animation).
719
720    variable aprefix   {}
721    variable araw      0
722
723    # Max length of module names and patchlevel information.
724
725    variable maxml 0
726    variable maxvl 0
727
728    # Map from internal stati to the displayed human readable
729    # strings. This includes the trailing whitespace needed for
730    # vertical alignment.
731
732    variable  xvstatus
733    array set xvstatus {
734	ok      {     }
735	none    {None }
736	aborted {Skip }
737	error   {ERR  }
738	fail    {FAILS}
739    }
740}
741
742##
743# ###
744
745package provide sak::test::run 1.0
746
747if 0 {
748    # Bad valgrind, ok no valgrind
749    if {$config(valgrind)} {
750	foreach e $valgrind {lappend cmd $e}
751	lappend cmd --num-callers=8
752	lappend cmd --leak-resolution=high
753	lappend cmd -v --leak-check=yes
754	lappend cmd --show-reachable=yes
755    }
756    lappend cmd $sh
757    lappend cmd [Driver] -modules $modules
758}
759