Megatest

Check-in [03d2fdb2d2]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Brought captain-ulex up to date with v1.66
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.66-captain-ulex
Files: files | file ages | folders
SHA1: 03d2fdb2d2ce9e709e60fbff0aa1b9f3597a53cd
User & Date: matt on 2020-07-05 22:13:10
Other Links: branch diff | manifest | tags
Context
2020-07-05
23:44
Added apimod.scm and got it all to compile again check-in: 0c080a2500 user: matt tags: v1.66-captain-ulex
22:13
Brought captain-ulex up to date with v1.66 check-in: 03d2fdb2d2 user: matt tags: v1.66-captain-ulex
2020-07-04
22:45
Added MT_STEP_NAME check-in: 5daa86cb52 user: matt tags: v1.66
2020-06-25
23:43
Pulled in parts of the ulex partial implementation check-in: d6e38724ed user: matt tags: v1.66-captain-ulex
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified Makefile from [b4db5ed2c3] to [1e26becbe0].

︙
29
30
31
32
33
34
35
36

37
38
39
40
41
42
43

29
30
31
32
33
34
35

36
37
38
39
40
41
42
43








-
+








           sdb.scm rmt.scm api.scm subrun.scm portlogger.scm		\
           archive.scm env.scm diff-report.scm				\
           cgisetup/models/pgdb.scm

# module source files
# ftail.scm rmtmod.scm commonmod.scm removed
MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
            mtargs.scm commonmod.scm dbmod.scm adjutant.scm
            mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          vg.scm

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)
︙
111
112
113
114
115
116
117
118


119
120
121
122
123
124
125

111
112
113
114
115
116
117

118
119
120
121
122
123
124
125
126








-
+
+








        rpc-transport.o \
	runconfig.o \
	runs.o \
	server.o \
	tasks.o \
	tdb.o \
	tests.o \
	subrun.o
	subrun.o \
        ezsteps.o

#        mofiles/commonmod.o \

tcmt : $(TCMTOBJS) tcmt.scm
	csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
︙
167
168
169
170
171
172
173

174
175
176

177
178
179
180
181
182
183

168
169
170
171
172
173
174
175
176
177

178
179
180
181
182
183
184
185








+


-
+









dcommon.o : run_records.scm

mofiles/stml2.o : mofiles/cookie.o

# special include based modules
mofiles/pkts.o      : pkts/pkts.scm
mofiles/stml2.o     : cookie.o
# mofiles/mtargs.o    : mtargs/mtargs.scm
# mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm
# mofiles/ulex.o      : ulex/ulex.scm
mofiles/ulex.o      : ulex/ulex.scm
mofiles/mutils.o    : mutils/mutils.scm
mofiles/cookie.o    : stml2/cookie.scm
mofiles/stml2.o     : stml2/stml2.scm

# for the modularized stuff
rmt.o : mofiles/ducttape-lib.o mofiles/pkts.o mofiles/stml2.o mofiles/mutils.o mofiles/mtargs.o
︙

Modified TODO from [365675e0c2] to [ff0b580779]. 

1

2
3
4
5
6
7
8


1
2
3
4
5
6
7
8

-
+








#  Copyright 2006-2017, Matthew Welland.
#  Copyright 2006-2020, Matthew Welland.
# 
# This file is part of Megatest.
# 
#     Megatest is free software: you can redistribute it and/or modify
#     it under the terms of the GNU General Public License as published by
#     the Free Software Foundation, either version 3 of the License, or
#     (at your option) any later version.
︙

Modified configure from [04750a0dcd] to [08e182d3ee].

︙
79
80
81
82
83
84
85

86
87
88
89
90
91
92

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93








+








if [[ ! $(type csi) ]];then
    echo "Chicken build needed."
    echo "BUILD_CHICKEN=yes" >> makefile.inc
    configure_dependencies
    echo "include chicken.makefile" >> makefile.inc
else
    echo "CSIPATH=$(which csi)" >> makefile.inc
    CSIPATH=$(which csi)
    echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
fi

# Make setup scripts
echo "#!/bin/bash" > setup.sh
echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
︙

Modified db.scm from [d17c8fc75a] to [c751e4a69e].

︙
1745
1746
1747
1748
1749
1750
1751
1752


1753
1754
1755
1756
1757
1758
1759

1745
1746
1747
1748
1749
1750
1751

1752
1753
1754
1755
1756
1757
1758
1759
1760








-
+
+








                        (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
                        (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "PASS" "Test stopped responding but it has PASSED; marking it PASS in the DB.")
                      )
                      (begin
                      (debug:print 0 *default-log-port* "INFO: test " test-id " final state/status is not COMPLETED/PASS. It is " result)
                      (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")
                      )
                     )
                     ) ;;call end of eud of run detection for posthook
                     (launch:end-of-run-check run-id)
                    )
                  )
                  all-ids)
             )
         )
       )
     )
︙

Modified dcommon.scm from [ada970eba5] to [30bf3c6504].

︙
614
615
616
617
618
619
620
621



























































622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643

644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687

614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682

683


















684





































685
686
687
688
689
690
691









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


-

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








    ;; (iup:attribute-set! general-matrix "2:0" "Area")
    ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; Megatest version
    (iup:attribute-set! general-matrix "2:0" "Version")
    (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

    general-matrix))

(define (dcommon:stats-updater commondat tabdat stats-matrix)
  (if (and (iup:ihandle? stats-matrix)
	   (dashboard:database-changed? commondat tabdat context-key: 'run-stats))
      (let* ((changed      #f)
	     (run-stats    (rmt:get-run-stats))
	     (indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
	     (row-indices  (car indices))
	     (col-indices  (cadr indices))
	     (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
	     (max-col      (if (null? col-indices) 1 
			       (common:max (map cadr col-indices))))
	     (max-visible  (max (- (dboard:tabdat-num-tests tabdat) 15) 3))
	     (max-col-vis  (if (> max-col 10) 10 max-col))
	     (numrows      1)
	     (numcols      1))
	(iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
	(iup:attribute-set! stats-matrix "NUMCOL" max-col )
	(iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
	(iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
	(iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
	(print "row-indices: " row-indices " col-indices: " col-indices)
	;; Row labels
	(for-each (lambda (ind)
		    (let* ((name (car ind))
			   (num  (cadr ind))
			   (key  (conc num ":0")))
		      (if (not (equal? (iup:attribute stats-matrix key) name))
			  (begin
			    (set! changed #t)
			    (iup:attribute-set! stats-matrix key name)))))
		  row-indices)

	;; Col labels
	(for-each (lambda (ind)
		    (let* ((name (car ind))
			   (num  (cadr ind))
			   (key  (conc "0:" num)))
		      (if (not (equal? (iup:attribute stats-matrix key) name))
			  (begin
			    (set! changed #t)
			    (iup:attribute-set! stats-matrix key name)))))
		  col-indices)

	;; Cell contents
	(for-each (lambda (entry)
		    (let* ((row-name (car entry))
			   (col-name (cadr entry))
			   (value    (caddr entry))
			   (row-num  (cadr (assoc row-name row-indices)))
			   (col-num  (cadr (assoc col-name col-indices)))
			   (key      (conc row-num ":" col-num)))
		      (if (not (equal? (iup:attribute stats-matrix key) value))
			  (begin
			    (set! changed #t)
			    (iup:attribute-set! stats-matrix key value)))))
		  run-stats)
	(if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))


(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (stats-updater (lambda ()
			 (if (dashboard:database-changed? commondat tabdat context-key: 'run-stats)
			     (let* ((run-stats    (rmt:get-run-stats))
				    (indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				    (row-indices  (car indices))
				    (col-indices  (cadr indices))
				    (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
				    (max-col      (if (null? col-indices) 1 
						      (common:max (map cadr col-indices))))
				    (max-visible  (max (- (dboard:tabdat-num-tests tabdat) 15) 3))
				    (max-col-vis  (if (> max-col 10) 10 max-col))
				    (numrows      1)
				    (numcols      1))
			       (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
			       (iup:attribute-set! stats-matrix "NUMCOL" max-col )
			       (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
			       (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
			       (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))

			  (dcommon:stats-updater commondat tabdat stats-matrix))))
			       ;; Row labels
			       (for-each (lambda (ind)
					   (let* ((name (car ind))
						  (num  (cadr ind))
						  (key  (conc num ":0")))
					     (if (not (equal? (iup:attribute stats-matrix key) name))
						 (begin
						   (set! changed #t)
						   (iup:attribute-set! stats-matrix key name)))))
					 row-indices)

			       ;; Col labels
			       (for-each (lambda (ind)
					   (let* ((name (car ind))
						  (num  (cadr ind))
						  (key  (conc "0:" num)))
					     (if (not (equal? (iup:attribute stats-matrix key) name))
						 (begin
						   (set! changed #t)
						   (iup:attribute-set! stats-matrix key name)))))
					 col-indices)

			       ;; Cell contents
			       (for-each (lambda (entry)
					   (let* ((row-name (car entry))
						  (col-name (cadr entry))
						  (value    (caddr entry))
						  (row-num  (cadr (assoc row-name row-indices)))
						  (col-num  (cadr (assoc col-name col-indices)))
						  (key      (conc row-num ":" col-num)))
					     (if (not (equal? (iup:attribute stats-matrix key) value))
						 (begin
						   (set! changed #t)
						   (iup:attribute-set! stats-matrix key value)))))
					 run-stats)
			       (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))
                             ))))
    ;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass 
    ;; (mark-for-update tabdat)
    ;; (stats-updater)
    (dboard:commondat-add-updater commondat stats-updater tab-num: tab-num)
    ;; (set! dashboard:update-summary-tab updater)
    (iup:attribute-set! stats-matrix "WIDTHDEF" "40")
    (iup:vbox
︙

Modified docs/manual/megatest_manual.html from [1464d6cd98] to [0dce8c2d65]. 

1
2
3
4
5

6
7
8
9
10
11
12

1
2
3
4

5
6
7
8
9
10
11
12





-
+








<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<meta name="generator" content="AsciiDoc 8.6.7">
<meta name="generator" content="AsciiDoc 8.6.10">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */

/* Default font. */
body {
  font-family: Georgia,serif;
︙
82
83
84
85
86
87
88
89




90
91
92



93
94
95
96
97
98
99

82
83
84
85
86
87
88

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105








-
+
+
+
+



+
+
+









ul, ol, li > p {
  margin-top: 0;
}
ul > li     { color: #aaa; }
ul > li > * { color: black; }

pre {
.monospaced, code, pre {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
  padding: 0;
  margin: 0;
}
pre {
  white-space: pre-wrap;
}

#author {
  color: #527bbd;
  font-weight: bold;
  font-size: 1.1em;
}
#email {
︙
214
215
216
217
218
219
220
221

222
223
224
225
226
227
228

220
221
222
223
224
225
226

227
228
229
230
231
232
233
234








-
+









div.exampleblock > div.content {
  border-left: 3px solid #dddddd;
  padding-left: 0.5em;
}

div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; }
span.image img { border-style: none; vertical-align: text-bottom; }
a.image:visited { color: white; }

dl {
  margin-top: 0.8em;
  margin-bottom: 0.8em;
}
dt {
︙
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429

416
417
418
419
420
421
422






423
424
425
426
427
428
429








-
-
-
-
-
-










/*
 * xhtml11 specific
 *
 * */

tt {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
}

div.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
div.tableblock > table {
  border: 3px solid #527bbd;
}
︙
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468

449
450
451
452
453
454
455






456
457
458
459
460
461
462








-
-
-
-
-
-










/*
 * html5 specific
 *
 * */

.monospaced {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
}

table.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
thead, p.tableblock.header {
  font-weight: bold;
  color: #527bbd;
︙
534
535
536
537
538
539
540


541
542
543
544
545
546
547

528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543








+
+








body.manpage div.sectionbody {
  margin-left: 3em;
}

@media print {
  body.manpage div#toc { display: none; }
}


@media screen {
  body {
    max-width: 50em; /* approximately 80 characters wide */
    margin-left: 16em;
  }

  #toc {
︙
2330
2331
2332
2333
2334
2335
2336
2337

2338
2339
2340
2341
2342
2343
2344

2326
2327
2328
2329
2330
2331
2332

2333
2334
2335
2336
2337
2338
2339
2340








-
+








</div></div>
</div>
<div class="sect2">
<h3 id="_trim_trailing_spaces">Trim trailing spaces</h3>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">As of Megatest version v1.6548 trim-trailing-spaces defaults to yes.</td>
</tr></table>
</div>
<div class="listingblock">
<div class="content monospaced">
<pre>[configf:settings trim-trailing-spaces no]
︙
2610
2611
2612
2613
2614
2615
2616
2617

2618
2619
2620
2621
2622
2623
2624

2606
2607
2608
2609
2610
2611
2612

2613
2614
2615
2616
2617
2618
2619
2620








-
+








<pre># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">Dynamic waiton lists must be capable of being calculated at the
beginning of a run. This is because Megatest walks the tree of waitons
to create the list of tests to execute.</td>
</tr></table>
</div>
<div class="listingblock">
︙
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917









2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935


























2936
2937
2938
2939
2940
2941
2942

2904
2905
2906
2907
2908
2909
2910



2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970








-
-
-
+
+
+
+
+
+
+
+
+


















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








<h3 id="_disks">Disks</h3>
<div class="paragraph"><p>A disks section in testconfig will override the disks section in
megatest.config. This can be used to allocate disks on a per-test or per item
basis.</p></div>
</div>
<div class="sect2">
<h3 id="_controlled_waiver_propagation">Controlled waiver propagation</h3>
<div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED</p></div>
<div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)</p></div>
<div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED
or if the test/itempath is listed under the matching target in the
waivers roll forward file (see below for file spec) then apply the
following rules from the testconfig: If a waiver check is specified in
the testconfig apply the check and if it passes then set this FAIL to
WAIVED</p></div>
<div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename,
filepatterns and 2) the rulename script spec (note that "diff" and
"logpro" are predefined)</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

# This builtin rule is the default if there is no &lt;waivername&gt;.logpro file
# diff   diff %file1% %file2%

# This builtin rule is applied if a &lt;waivername&gt;.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html</pre>
</div></div>
<div class="sect3">
<h4 id="_waiver_roll_forward_files">Waiver roll-forward files</h4>
<div class="paragraph"><p>To transfer waivers from one Megatest area to another it is possible
to dump waivers into a file and reference that file in another area.</p></div>
<div class="listingblock">
<div class="title">Dumping the waivers</div>
<div class="content monospaced">
<pre>megatest -list-waivers -runname %-a &gt; mywaivers.dat</pre>
</div></div>
<div class="listingblock">
<div class="title">Referencing the saved waivers</div>
<div class="content monospaced">
<pre># In megatest.config, all files listed will be loaded - recomended to use
# variables to select directorys to minimize what gets loaded.
[setup]
waivers-dirs /path/to/waiver/files /another/path/to/waiver/files</pre>
</div></div>
<div class="listingblock">
<div class="title">Waiver files format</div>
<div class="content monospaced">
<pre>[the/target/here]
# comments are fine
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_ezsteps">Ezsteps</h3>
<div class="listingblock">
<div class="title">Example ezsteps with logpro rules</div>
<div class="content monospaced">
<pre>[ezsteps]
︙
3083
3084
3085
3086
3087
3088
3089
3090

3091
3092
3093
3094
3095
3096
3097

3111
3112
3113
3114
3115
3116
3117

3118
3119
3120
3121
3122
3123
3124
3125








-
+








<div class="content monospaced">
<pre>[triggers]
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the double-dash</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
but since triggers can be called in various contexts not all variables are
available at all times. The trigger script should check for the variable and
︙
3382
3383
3384
3385
3386
3387
3388
3389


3390
3391
3392
3393

3410
3411
3412
3413
3414
3415
3416

3417
3418
3419
3420
3421
3422








-
+
+





</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.5<br>
Last updated 2020-06-17 07:41:12 PDT
Last updated
 2020-06-29 20:32:05 MST
</div>
</div>
</body>
</html>

Modified docs/manual/megatest_manual.txt from [15718f423c] to [69ab724537].

︙
110
111
112
113
114
115
116

117
118
119
120
121
122
123
124
125
126
127

110
111
112
113
114
115
116
117
118
119
120

121
122
123
124
125
126
127








+



-








include::getting_started.txt[]

include::study_plan.txt[]

// :leveloffset: 0

include::writing_tests.txt[]

include::howto.txt[]

include::reference.txt[]


Megatest Internals
------------------

["graphviz", "server.png"]
----------------------------------------------------------------------
include::server.dot[]
︙

Modified docs/manual/reference.txt from [d257a69331] to [6c625c002f].

︙
625
626
627
628
629
630
631
632
633






634
635



636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654



























655
656
657
658
659
660
661

625
626
627
628
629
630
631


632
633
634
635
636
637
638

639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694








-
-
+
+
+
+
+
+

-
+
+
+



















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








A disks section in testconfig will override the disks section in
megatest.config. This can be used to allocate disks on a per-test or per item
basis.

Controlled waiver propagation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig:
If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED
If test is FAIL and previous test in run with same MT_TARGET is WAIVED
or if the test/itempath is listed under the matching target in the
waivers roll forward file (see below for file spec) then apply the
following rules from the testconfig: If a waiver check is specified in
the testconfig apply the check and if it passes then set this FAIL to
WAIVED

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)
Waiver check has two parts, 1) a list of waiver, rulename,
filepatterns and 2) the rulename script spec (note that "diff" and
"logpro" are predefined)

-----------------
###### EXAMPLE FROM testconfig #########
# matching file(s) will be diff'd with previous run and logpro applied
# if PASS or WARN result from logpro then WAIVER state is set
#
[waivers]
# logpro_file    rulename      input_glob
waiver_1         logpro        lookittmp.log

[waiver_rules]

# This builtin rule is the default if there is no <waivername>.logpro file
# diff   diff %file1% %file2%

# This builtin rule is applied if a <waivername>.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
-----------------

Waiver roll-forward files
^^^^^^^^^^^^^^^^^^^^^^^^^

To transfer waivers from one Megatest area to another it is possible
to dump waivers into a file and reference that file in another area.

.Dumping the waivers
---------------------------
megatest -list-waivers -runname %-a > mywaivers.dat
---------------------------

.Referencing the saved waivers
---------------------------
# In megatest.config, all files listed will be loaded - recomended to use
# variables to select directorys to minimize what gets loaded.
[setup]
waivers-dirs /path/to/waiver/files /another/path/to/waiver/files
---------------------------

.Waiver files format
---------------------------
[the/target/here]
# comments are fine
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test 
---------------------------

Ezsteps
~~~~~~~

.Example ezsteps with logpro rules
-----------------
[ezsteps]
lookittmp   ls /tmp
︙

Modified docs/manual/server.png from [ae7d7ee58e] to [da85cb6703].

cannot compute difference between binary files

Modified ezsteps.scm from [b166d59095] to [5de5d166c7].

︙
15
16
17
18
19
20
21
22


23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
































40































































































































































41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59


60
61
62
63
64
65
66

15
16
17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249

250
251
252
253
254
255
256
257
258








-
+
+

















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


















-
+
+








;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use srfi-1 posix regex srfi-69 directory-utils)
(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
     z3 csv typed-records pathname-expand matchable)

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")


;;(rmt:get-test-info-by-id run-id test-id) -> testdat

;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))
	;; (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) "" info)))
	;; (stepproc       (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) info #f)))
	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	 (stepparams     (if (and (list? stepparts)
				  (> (length stepparts) 1))
			     (list-ref stepparts 2)
			     #f)) ;; for future use, {VAR=1,2,3}, run step for each
	 (paramparts     (if (string? stepparams)
			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
			     '()))
	 (subrun         (alist-ref "subrun" paramparts equal?))
	 (stepcmd        (if (and (list? stepparts)
				  (> (length stepparts) 2))
			     (list-ref stepparts 3)
			     (conc "# error, no command for step "stepname)))
	 (script         "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
	 (logpro-file    (conc stepname ".logpro"))
	 (html-file      (conc stepname ".html"))
	 (dat-file       (conc stepname ".dat"))
	 (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
	 (logpro-used    (common:file-exists? logpro-file)))
    (setenv "MT_STEP_NAME" stepname)
    (hash-table-set! all-steps-dat stepname `((params . ,paramparts)))
    (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
                 ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)

    
    (if (and tconfig-logpro
	     (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
	(begin
	  (with-output-to-file logpro-file
	    (lambda ()
	      (print ";; logpro file extracted from testconfig\n"
		     ";;")
	      (print tconfig-logpro)))
	  (set! logpro-used #t)))
    
    ;; NB// can safely assume we are in test-area directory
    (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
		 " stepparams: " stepparams " stepcmd: " stepcmd)
    
    ;; ;; first source the previous environment
    ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
    ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
    ;;   (if (and prevstep (common:file-exists? prev-env))
    ;;       (set! script (conc script "source " prev-env))))
    
    ;; call the command using mt_ezstep
    ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
    
    (debug:print 4 *default-log-port* "script: " script)
    (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
    ;; now launch the actual process
    (call-with-environment-variables 
     (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
     (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
       (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
	      (pid #f))
	 (let ((proc (lambda ()
		       (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
	   (if subrun
               (begin
                 (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
                 (common:without-vars proc "^MT_.*"))
	       (proc)))
	 
         (with-output-to-file "Makefile.ezsteps"
           (lambda ()
             (print stepname ".log :")
             (print "\t" cmd)
             (if (common:file-exists? (conc stepname ".logpro"))
                 (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
             (print)
             (print stepname " : " stepname ".log")
             (print))
           #:append)

	 (rmt:test-set-top-process-pid run-id test-id pid)
	 (let processloop ((i 0))
	   (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
		       (mutex-lock! m)
		       (launch:einf-pid-set!         exit-info pid)         ;; (vector-set! exit-info 0 pid)
		       (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
		       (launch:einf-exit-code-set!   exit-info exit-code)   ;; (vector-set! exit-info 2 exit-code)
		       (mutex-unlock! m)
		       (if (eq? pid-val 0)
			   (begin
			     (thread-sleep! 2)
			     (processloop (+ i 1))))
		       )))))
    (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
    ;; now run logpro if needed
    (if logpro-used
	(let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
               (pid        (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
	  (let processloop ((i 0))
	    (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
			(mutex-lock! m)
			;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
			(launch:einf-pid-set!         exit-info pid)         ;; (vector-set! exit-info 0 pid)
			(launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
			(launch:einf-exit-code-set!   exit-info exit-code)   ;; (vector-set! exit-info 2 exit-code)
			(mutex-unlock! m)
			(if (eq? pid-val 0)
			    (begin
			      (thread-sleep! 2)
			      (processloop (+ i 1)))))
	    (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
    
    (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	  (logfna (if logpro-used (conc stepname ".html") ""))
	  (comment #f))
      (if logpro-used
	  (let ((datfile (conc stepname ".dat")))
	    ;; load the .dat file into the test_data table if it exists
	    (if (common:file-exists? datfile)
		(set! comment (launch:load-logpro-dat run-id test-id stepname)))
	    (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
    ;; set the test final status
    (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	   (this-step-status (cond
			      ((and (eq? process-exit-status 2) logpro-used) 'warn)   ;; logpro 2 = warnings
			      ((and (eq? process-exit-status 3) logpro-used) 'check)  ;; logpro 3 = check
			      ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived
			      ((and (eq? process-exit-status 5) logpro-used) 'abort)  ;; logpro 5 = abort
			      ((and (eq? process-exit-status 6) logpro-used) 'skip)   ;; logpro 6 = skip
			      ((eq? process-exit-status 0)                   'pass)   ;; logpro 0 = pass
			      (else 'fail)))
	   (overall-status   (cond
			      ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3)
			      ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3)
			      (else 'fail)))
	   (next-status      (cond 
			      ((eq? overall-status 'pass) this-step-status)
			      ((eq? overall-status 'warn)
			       (if (eq? this-step-status 'fail) 'fail 'warn))
			      ((eq? overall-status 'abort) 'abort)
			      (else 'fail)))
	   (next-state       ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
	    (cond
	     ((null? tal) ;; more to run?
	      "COMPLETED")
	     (else "RUNNING"))))
      (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used 
		   " this-step-status: " this-step-status " overall-status: " overall-status 
		   " next-status: " next-status " rollup-status: "  (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
      (case next-status
	((warn)
	 (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "WARN" 
				 (if (eq? this-step-status 'warn) "Logpro warning found" #f)
				 #f))
	((check)
	 (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "CHECK" 
				 (if (eq? this-step-status 'check) "Logpro check found" #f)
				 #f))
	((waived)
	 (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "WAIVED" 
				 (if (eq? this-step-status 'check) "Logpro waived found" #f)
				 #f))
	((abort)
	 (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "ABORT" 
				 (if (eq? this-step-status 'abort) "Logpro abort found" #f)
				 #f))
	((skip)
	 (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "SKIP" 
				 (if (eq? this-step-status 'skip) "Logpro skip found" #f)
				 #f))
	((pass)
	 (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
	(else ;; 'fail
	 (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
	 (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
	 )))
    logpro-used))

(define (ezsteps:run-from testdat start-step-name run-one)
  ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
  (let* ((do-update-test-state-status #f)
         (test-run-dir  ;; (filedb:get-path *fdb* 
	  (db:test-get-rundir testdat)) ;; )
	 (testconfig    (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
	 (ezstepslst    (hash-table-ref/default testconfig "ezsteps" '()))
	 (run-mutex     (make-mutex))
	 (rollup-status 0)
         (rollup-status-string #f)
         (rollup-status-sym #f)
	 (exit-info     (vector #t #t #t))
	 (test-id       (db:test-get-id        testdat))
	 (run-id        (db:test-get-run_id    testdat))
	 (test-name     (db:test-get-testname  testdat))
         (orig-test-state (db:test-get-state   testdat))
         (orig-test-status (db:test-get-status testdat))
	 (kill-job      #f)) ;; for future use (on re-factoring with launch.scm code
	 (kill-job      #f) ;; for future use (on re-factoring with launch.scm code
	 (the-step-params '())) ;; not exactly "functional"

    ;; keep trying till NFS deigns to populate test run dir on this host
    (let loop ((count 5))
      (if (not (common:file-exists? test-run-dir))
	  ;;(push-directory test-run-dir)
	  (if (> count 0)
	      (begin
︙
76
77
78
79
80
81
82
83
84




85
86
87
88
89
90
91
92
93
94
95
96
97
98


99
100
101
102
103
104
105

268
269
270
271
272
273
274


275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301








-
-
+
+
+
+














+
+








	(message-window "ERROR: You can only re-run steps defined via ezsteps")
	(begin
	  (let loop ((ezstep   (car ezstepslst))
		     (tal      (cdr ezstepslst))
                     (status-sym-so-far 'pass)
		     ;;(runflag  #f)
                     (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
	    (if (vector-ref exit-info 1)
		(let* ((stepname    (car ezstep))  ;; do stuff to run the step
	    (if (or (vector-ref exit-info 1)
		    (equal? (alist-ref 'keep-going prev-step-params) 'yes))
		(let* ((prev-step-params the-step-params) ;; need to snag this now
		       (stepname    (car ezstep))  ;; do stuff to run the step
                       (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro")))
		       (stepinfo    (cadr ezstep))
		       (stepparts   (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
		       (stepparms   (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each 
		       (stepcmd     (list-ref stepparts 3))
		       (script      (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep
                       (saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name)))
                       (proceed-with-this-step
                        (or (not start-step-name)
                            (equal? stepname start-step-name)
                            (and saw-start-step-name (not run-one))
                            saw-start-step-name-next
                            (and start-step-name (equal? stepname start-step-name))))
                       )
		  (debug:print 0 *default-log-port* "NOTE: stepparms=" stepparms)
		  (set! prev-step-params stepparms)
                  (set! do-update-test-state-status (and proceed-with-this-step (null? tal)))
                  ;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status)
                  (cond
                   ((and (not proceed-with-this-step) (null? tal))
                    'done)
                   ((not proceed-with-this-step)
                      (loop (car tal)
︙

Modified launch.scm from [2b4d400b2f] to [3a184b6bad].

︙
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

54
55







56
57
58
59
60
61
62

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

54
55

56
57
58
59
60
61
62
63
64
65
66
67
68
69








+


















-
+

-
+
+
+
+
+
+
+








(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")

;;======================================================================
;; ezsteps
;;======================================================================

;; ezsteps were going to be coded as
;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute
;;   BUT
;; now are
;; stepname {VAR=first,second,third ...} command ...
;; where the {VAR=first,second,third ...} is optional.

;; given an exit code and whether or not logpro was used calculate OK/BAD
;; return #t if we are ok, #f otherwise
(define (steprun-good? logpro exitcode)
(define (steprun-good? logpro exitcode stepparms)
  (or (eq? exitcode 0)
      (and logpro (eq? exitcode 2))))
      (and logpro (eq? exitcode 2)) ;; shouldn't this be (member exitcode 2 ...) with the other ok codes?
      (let* ((params (alist-ref 'params stepparms)) ;; get the params section
	     (keep-going (if params
			     (alist-ref "keep-going" params equal?)
			     #f)))
	(debug:print 0 *default-log-port* "keep-going=" keep-going)
	(and keep-going (equal? (car keep-going) "yes")))))

;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
  (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
    (if enccmd
	(common:read-encoded-string enccmd)
	'())))
︙
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285

90
91
92
93
94
95
96





























































































































































































97
98
99
100
101
102
103








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








	  ;;  )
	  (cond
	   ((equal? status "PASS") "PASS") ;; skip the message part if status is pass
	   (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message")))
	   (else #f)))
	#f)))

(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) ;;; TODO: deprecate me in favor of ezsteps.scm
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))
	;; (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) "" info)))
	;; (stepproc       (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) info #f)))
	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	 (stepparams     (if (and (list? stepparts)
				  (> (length stepparts) 1))
			     (list-ref stepparts 2)
			     #f)) ;; for future use, {VAR=1,2,3}, run step for each
	 (paramparts     (if (string? stepparams)
			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
			     '()))
	 (subrun         (alist-ref "subrun" paramparts equal?))
	 (stepcmd        (if (and (list? stepparts)
				  (> (length stepparts) 2))
			     (list-ref stepparts 3)
			     (conc "# error, no command for step "stepname)))
	 (script         "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
	 (logpro-file    (conc stepname ".logpro"))
	 (html-file      (conc stepname ".html"))
	 (dat-file       (conc stepname ".dat"))
	 (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
	 (logpro-used    (common:file-exists? logpro-file)))

    (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
                 ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
    
    (if (and tconfig-logpro
	     (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
	(begin
	  (with-output-to-file logpro-file
	    (lambda ()
	      (print ";; logpro file extracted from testconfig\n"
		     ";;")
	      (print tconfig-logpro)))
	  (set! logpro-used #t)))
    
    ;; NB// can safely assume we are in test-area directory
    (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
		 " stepparams: " stepparams " stepcmd: " stepcmd)
    
    ;; ;; first source the previous environment
    ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
    ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
    ;;   (if (and prevstep (common:file-exists? prev-env))
    ;;       (set! script (conc script "source " prev-env))))
    
    ;; call the command using mt_ezstep
    ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
    
    (debug:print 4 *default-log-port* "script: " script)
    (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
    ;; now launch the actual process
    (call-with-environment-variables 
     (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
     (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
       (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
	      (pid #f))
	 (let ((proc (lambda ()
		       (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
	   (if subrun
               (begin
                 (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
                 (common:without-vars proc "^MT_.*"))
	       (proc)))
	 
         (with-output-to-file "Makefile.ezsteps"
           (lambda ()
             (print stepname ".log :")
             (print "\t" cmd)
             (if (common:file-exists? (conc stepname ".logpro"))
                 (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
             (print)
             (print stepname " : " stepname ".log")
             (print))
           #:append)

	 (rmt:test-set-top-process-pid run-id test-id pid)
	 (let processloop ((i 0))
	   (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
		       (mutex-lock! m)
		       (launch:einf-pid-set!         exit-info pid)         ;; (vector-set! exit-info 0 pid)
		       (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
		       (launch:einf-exit-code-set!   exit-info exit-code)   ;; (vector-set! exit-info 2 exit-code)
		       (mutex-unlock! m)
		       (if (eq? pid-val 0)
			   (begin
			     (thread-sleep! 2)
			     (processloop (+ i 1))))
		       )))))
    (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
    ;; now run logpro if needed
    (if logpro-used
	(let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
               (pid        (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
	  (let processloop ((i 0))
	    (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
			(mutex-lock! m)
			;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
			(launch:einf-pid-set!         exit-info pid)         ;; (vector-set! exit-info 0 pid)
			(launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
			(launch:einf-exit-code-set!   exit-info exit-code)   ;; (vector-set! exit-info 2 exit-code)
			(mutex-unlock! m)
			(if (eq? pid-val 0)
			    (begin
			      (thread-sleep! 2)
			      (processloop (+ i 1)))))
	    (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
    
    (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	  (logfna (if logpro-used (conc stepname ".html") ""))
	  (comment #f))
      (if logpro-used
	  (let ((datfile (conc stepname ".dat")))
	    ;; load the .dat file into the test_data table if it exists
	    (if (common:file-exists? datfile)
		(set! comment (launch:load-logpro-dat run-id test-id stepname)))
	    (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
      (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
    ;; set the test final status
    (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	   (this-step-status (cond
			      ((and (eq? process-exit-status 2) logpro-used) 'warn)   ;; logpro 2 = warnings
			      ((and (eq? process-exit-status 3) logpro-used) 'check)  ;; logpro 3 = check
			      ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived
			      ((and (eq? process-exit-status 5) logpro-used) 'abort)  ;; logpro 5 = abort
			      ((and (eq? process-exit-status 6) logpro-used) 'skip)   ;; logpro 6 = skip
			      ((eq? process-exit-status 0)                   'pass)   ;; logpro 0 = pass
			      (else 'fail)))
	   (overall-status   (cond
			      ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3)
			      ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3)
			      (else 'fail)))
	   (next-status      (cond 
			      ((eq? overall-status 'pass) this-step-status)
			      ((eq? overall-status 'warn)
			       (if (eq? this-step-status 'fail) 'fail 'warn))
			      ((eq? overall-status 'abort) 'abort)
			      (else 'fail)))
	   (next-state       ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
	    (cond
	     ((null? tal) ;; more to run?
	      "COMPLETED")
	     (else "RUNNING"))))
      (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used 
		   " this-step-status: " this-step-status " overall-status: " overall-status 
		   " next-status: " next-status " rollup-status: "  (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
      (case next-status
	((warn)
	 (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "WARN" 
				 (if (eq? this-step-status 'warn) "Logpro warning found" #f)
				 #f))
	((check)
	 (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "CHECK" 
				 (if (eq? this-step-status 'check) "Logpro check found" #f)
				 #f))
	((waived)
	 (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "WAIVED" 
				 (if (eq? this-step-status 'check) "Logpro waived found" #f)
				 #f))
	((abort)
	 (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "ABORT" 
				 (if (eq? this-step-status 'abort) "Logpro abort found" #f)
				 #f))
	((skip)
	 (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
	 ;; NB// test-set-status! does rdb calls under the hood
	 (tests:test-set-status! run-id test-id next-state "SKIP" 
				 (if (eq? this-step-status 'skip) "Logpro skip found" #f)
				 #f))
	((pass)
	 (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
	(else ;; 'fail
	 (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
	 (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
	 )))
    logpro-used))

(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
  ;; (let-values
  ;;  (((pid exit-status exit-code)
  ;;    (run-n-wait fullrunscript)))
  ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
  ;; Since we should have a clean slate at this time there is no need to do 
  ;; any of the other stuff that tests:test-set-status! does. Let's just
︙
346
347
348
349
350
351
352
353

354
355
356
357
358
359
360
361
362
363
364
365





366
367
368
369

370
371
372
373
374
375
376

164
165
166
167
168
169
170

171
172
173
174
175
176
177
178
179
180
181


182
183
184
185
186
187
188
189

190
191
192
193
194
195
196
197








-
+










-
-
+
+
+
+
+



-
+








              (set! ezsteps #t) ;; set the needed flag
	      (set! ezstepslst
                    (append (or ezstepslst '())
                            (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))

	;; process the ezsteps
	(if ezsteps
	    (begin
	    (let* ((all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist; where  'params is the params list (add other stuff as needed)
	      (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
	      ;; if ezsteps was defined then we are sure to have at least one step but check anyway
	      (if (not (> (length ezstepslst) 0))
		  (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
		  (let loop ((ezstep (car ezstepslst))
			     (tal    (cdr ezstepslst))
			     (prevstep #f))
                    (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
		    ;; check exit-info (vector-ref exit-info 1)
		    (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
			(let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
			      (stepname    (car ezstep)))
			(let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat))
			       (stepname    (car ezstep))
			       (stepparms   (hash-table-ref all-steps-dat stepname)))
			  (setenv "MT_STEP_NAME" stepname)
			  (pp (hash-table->alist all-steps-dat))
			  ;; if logpro-used read in the stepname.dat file
			  (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
			      (launch:load-logpro-dat run-id test-id stepname))
			  (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
			  (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
			      (if (not (null? tal))
				  (loop (car tal) (cdr tal) stepname))
			      (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
			(debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))))

(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
  (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
︙
907
908
909
910
911
912
913
914

915
916
917
918



919
920







921
922
923
924
925
926
927

728
729
730
731
732
733
734

735
736
737
738
739
740
741
742


743
744
745
746
747
748
749
750
751
752
753
754
755
756








-
+




+
+
+
-
-
+
+
+
+
+
+
+








(define (launch:end-of-run-check run-id )
    (let*	((not-completed-cnt (rmt:get-not-completed-cnt run-id))  
           (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
           (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
           (current-state (rmt:get-run-state run-id))
           (current-status (rmt:get-run-status run-id)))
     ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing 
     (debug:print 0 *default-log-port* "rollup run state/status")                      
     (debug:print 0 *default-log-port* "Running test cnt :" running-cnt)                      
     (rmt:set-state-status-and-roll-up-run  run-id current-state current-status)
     (runs:update-junit-test-reporter-xml run-id) 
     (cond 
       ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
                (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
                (begin
           	(debug:print 4 *default-log-port* "look for  post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id)))
           	(debug:print 0 *default-log-port* "look for  post hook.")
          	(runs:run-post-hook run-id))
                (debug:print 0 *default-log-port* "End of Run Detected.")
                (rmt:set-var (conc "end-of-run-" run-id) "yes")
                ;(thread-sleep! 10)
          	(runs:run-post-hook run-id)
                (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id)))
                (common:simple-unlock (conc "endOfRun" run-id)))
                 (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id)))))
        ((> running-cnt 3) 
        	  (debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
        ((> running-cnt 0)
            (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
   				  (let ((kill-cnt (launch:kill-tests-if-dead run-id)))
           			(if (and all-test-launched  (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
           					(launch:end-of-run-check run-id)))) ;;todo
︙

Modified megatest-version.scm from [283b980c38] to [bdb917f339].

︙
16
17
18
19
20
21
22
23


16
17
18
19
20
21
22

23








-
+

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6602)
(define megatest-version 1.6603)

Modified megatest.scm from [7055cf560a] to [5271a099fb].

︙
181
182
183
184
185
186
187


188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199

200
201
202
203

204
205
206
207
208
209
210








+
+










-




-








  :units                  : name of the units for value, expected_value etc. (optional)
  -load-test-data         : read test specific data for storage in the test_data table
                            from standard in. Each line is comma delimited with four
                            fields category,variable,value,comment

Queries
  -list-runs patt         : list runs matching pattern \"patt\", % is the wildcard
  -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
  -show-keys              : show the keys used in this megatest setup
  -test-files targpatt    : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
                            returns list sorted by age ascending, see examples below
  -test-paths             : get the test paths matching target, runname, item and test
                            patterns.
  -list-disks             : list the disks available for storing runs
  -list-targets           : list the targets in runconfigs.config
  -list-db-targets        : list the target combinations used in the db
  -show-config            : dump the internal representation of the megatest.config file
  -show-runconfig         : dump the internal representation of the runconfigs.config file
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
  -show-cmdinfo           : dump the command info for a test (run in test environment)
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName
  -since N                : get list of runs changed since time N (Unix seconds)
  -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
  -sort fieldname         : in -list-runs sort tests by this field
  -testdata-csv [categorypatt/]varpatt  : dump testdata for given category

Misc 
  -start-dir path         : switch to this directory before running megatest
  -contour cname          : add a level of hierarcy to the linktree and run paths
  -area-tag tagname       : add a tag to an area while syncing to pgdb
︙
252
253
254
255
256
257
258

259
260
261
262
263
264
265

252
253
254
255
256
257
258
259
260
261
262
263
264
265
266








+








  -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
  -list-run-time          : list time requered to complete runs. It supports following switches
                            -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
  -list-test-time	  : list time requered to complete each test in a run. It following following arguments
                            -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
  -syscheck               : do some very basic checks; write access and space in tmp, home, runs, links and 
                            is $DISPLAY valid 
  -list-waivers           : dump waivers for specified target, runname, testpatt to stdout

Diff report
  -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
                                                  and either -diff-email or -diff-html)
  -src-target <target>
  -src-runname <target>
  -diff-email <emails>    : comma separated list of email addresses to send diff report
︙
323
324
325
326
327
328
329

330
331
332
333
334
335
336

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338








+








			;; values and messages
			":category"
			":variable"
			":value"
			":expected"
			":tol"
			":units"

			;; misc
			"-start-dir"
                        "-run-patt"
                        "-target-patt"   
			"-contour"
                        "-area-tag"  
                        "-area"
︙
385
386
387
388
389
390
391

392
393
394
395
396
397
398

387
388
389
390
391
392
393
394
395
396
397
398
399
400
401








+








                        "-src-target"
                        "-src-runname"
                        "-diff-email"
			"-sync-to"			
			"-pgsync"
			"-kill-wait"    ;; wait this long before removing test (default is 10 sec)
                        "-diff-html"

			)
 		 (list  "-h" "-help" "--help"
			"-manual"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
︙
432
433
434
435
436
437
438

439
440
441
442
443
444
445

435
436
437
438
439
440
441
442
443
444
445
446
447
448
449








+








			"-list-disks"
			"-list-targets"
			"-list-db-targets"
			"-show-runconfig"
			"-show-config"
			"-show-cmdinfo"
			"-get-run-status"
			"-list-waivers"

			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests, respects -testpatt, defaults to %
			"-run"       ;; alias for -runall
			"-remove-runs"
︙
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704








































1705
1706
1707
1708
1709
1710
1711
1712

1693
1694
1695
1696
1697
1698
1699









1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739

1740
1741
1742
1743
1744
1745
1746








-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-








	  ;; (system (conc "rm -rf " tempdir))
	  (set! *didsomething* #t)
          (set! *time-to-exit* #t)
          ) ;; end if true branch (end of a let)
        ) ;; end if
    ) ;; end if -list-runs

;; Don't think I need this. Incorporated into -list-runs instead
;;
;; (if (and (args:get-arg "-since")
;; 	 (launch:setup))
;;     (let* ((since-time (string->number (args:get-arg "-since")))
;; 	   (run-ids    (db:get-changed-run-ids since-time)))
;;       ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;;       (print (sort run-ids <))
;;       (set! *didsomething* #t)))
;; list-waivers
(if (and (args:get-arg "-list-waivers")
	 (launch:setup))
    (let* ((runpatt     (or (args:get-arg "-runname") "%"))
	   (testpatt    (common:args-get-testpatt #f))
	   (keys        (rmt:get-keys)) 
	   (runsdat     (rmt:get-runs-by-patt
			 keys runpatt 
			 (common:args-get-target) #f #f
			 '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	   (runs        (db:get-rows runsdat))
	   (header      (db:get-header runsdat))
	   (results     (make-hash-table))  ;; [target] ( (testname/itempath . "comment") ... )
	   (addtest     (lambda (target testname itempath comment)
			  (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
								(hash-table-ref/default results target '())))))
	   (last-target #f))
      (for-each
       (lambda (run)
	 (let* ((run-id  (db:get-value-by-header run header "id"))
		(target  (rmt:get-target run-id))
		(runname (db:get-value-by-header run header "runname")) 
		(tests   (rmt:get-tests-for-run
			  run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc							     ;; use qryvals if test-spec provided
			  #f #f #f)))
	   (if (not (equal? target last-target))
	       (print "[" target "]"))
	   (set! last-target target)
	   (print "# " runname)
	   (for-each
	    (lambda (testdat)
	      (let* ((testfullname (conc (db:test-get-testname testdat)
					 (if (equal? "" (db:test-get-item-path testdat))
					     ""
					     (conc "/" (db:test-get-item-path testdat)))
					 )))
	      (print testfullname " " (db:test-get-comment testdat))))
	    tests)))
       runs)
      (set! *didsomething* #t)))
      
      
;;======================================================================
;; full run
;;======================================================================

(define (handle-run-requests target runname keys keyvals need-clean)	 
  (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
︙

Modified mtut.scm from [daf0c4d9a4] to [8133cd984a].

︙
21
22
23
24
25
26
27

28
29
30
31
32
33
34

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35








+









;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
   srfi-19  srfi-18 extras format regex regex-case
     (prefix dbi dbi:)
     (prefix sqlite3 sqlite3:)
     nanomsg)

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
︙
839
840
841
842
843
844
845
846
847

848
849
850
851
852
853
854

840
841
842
843
844
845
846


847
848
849
850
851
852
853
854








-
-
+








	      (rgconf    (car rgconfdat))
	      (all-areas (map car (configf:get-section mtconf "areas")))
	      (contours  (configf:get-section mtconf "contours"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering

	 ;;(print "rgentargs: " rgentargs)
	 
	 (for-each
	  (for-each
	  (lambda (runkey)
	    (let* ((keydats   (configf:get-section rgconf runkey)))
	      (for-each
	       (lambda (sense) ;; these are the sense rules
		 (let* ((key        (car sense))
			(val        (cadr sense))
			(keyparts   (string-split key ":")) ;; contour:ruletype:action:optional
︙
1427
1428
1429
1430
1431
1432
1433

1434
1435
1436
1437
1438
1439
1440

1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441








+








       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (areas     (configf:get-section mtconf "areas"))
	      (contours  (configf:get-section mtconf "contours"))
	      (pkts      (find-pkts pdb '(cmd) '()))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
         (sqlite3:set-busy-handler! (dbi:db-conn pdb) (sqlite3:make-busy-timeout 10000))
	 (for-each
	  (lambda (pktdat)
	    (let* ((pkta    (alist-ref 'apkt pktdat))
		   (action  (alist-ref 'A pkta))
		   (cmdline (pkt->cmdline pkta))
		   (uuid    (alist-ref 'Z pkta))
		   (user    (alist-ref 'U pkta))
︙

Modified rmtmod.scm from [b57423f852] to [698911aee9].

︙
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50


















51
52
53
54
55
56
57
58
59
60
61











62
63
64
65
66
67
68

69
70
71
72
73
74

75
76
77
78
79
80
81
82
83
84
85
86
87


88
89
90
91
92
93
94

26
27
28
29
30
31
32


















33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50











51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

68
69
70
71
72
73

74
75
76
77
78
79
80
81
82
83
84
85


86
87
88
89
90
91
92
93
94








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+






-
+





-
+











-
-
+
+








	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
(import (prefix ulex ulex:))

;; Hack to make these functions visible to the refactored code, goal is to eliminate these over time.
(define (rmt:send-receive . params) #f)
(define (http-transport:close-connections . params) #f)
;; from remote defstruct in common.scm
(define (remote-conndat-set! . params) #f)
(define (remote-server-url-set! . params) #f)
(define (remote-ro-mode . params) #f)
(define (remote-ro-mode-set! . params) #f)
(define (remote-ro-mode-checked-set! . params) #f)
(define (remote-ro-mode-checked . params) #f)
(define (debug:print . params) #f)
(define (debug:print-info . params) #f)

(define (set-functions send-receive        rsus
		       close-connections   rcs
		       dbgp                dbgpinfo
		       ro-mode             ro-mode-set
		       ro-mode-checked-set ro-mode-checked
;; ;; Hack to make these functions visible to the refactored code, goal is to eliminate these over time.
;; (define (rmt:send-receive . params) #f)
;; (define (http-transport:close-connections . params) #f)
;; ;; from remote defstruct in common.scm
;; (define (remote-conndat-set! . params) #f)
;; (define (remote-server-url-set! . params) #f)
;; (define (remote-ro-mode . params) #f)
;; (define (remote-ro-mode-set! . params) #f)
;; (define (remote-ro-mode-checked-set! . params) #f)
;; (define (remote-ro-mode-checked . params) #f)
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions send-receive        rsus
;; 		       close-connections   rcs
;; 		       dbgp                dbgpinfo
;; 		       ro-mode             ro-mode-set
;; 		       ro-mode-checked-set ro-mode-checked
		       ) 
  (set! rmt:send-receive                 send-receive)
  (set! remote-server-url-set!           rsus)
  (set! http-transport:close-connections close-connections)
  (set! remote-conndat-set!              rcs)
  (set! debug:print                      dbgp)
  (set! debug:print-info                 dbgpinfo)
  (set! remote-ro-mode                   ro-mode)
  (set! remote-ro-mode-set!              ro-mode-set)
  (set! remote-ro-mode-checked-set!      ro-mode-checked-set)
  (set! remote-ro-mode-checked           ro-mode-checked))
;; 		       ) 
;;   (set! rmt:send-receive                 send-receive)
;;   (set! remote-server-url-set!           rsus)
;;   (set! http-transport:close-connections close-connections)
;;   (set! remote-conndat-set!              rcs)
;;   (set! debug:print                      dbgp)
;;   (set! debug:print-info                 dbgpinfo)
;;   (set! remote-ro-mode                   ro-mode)
;;   (set! remote-ro-mode-set!              ro-mode-set)
;;   (set! remote-ro-mode-checked-set!      ro-mode-checked-set)
;;   (set! remote-ro-mode-checked           ro-mode-checked))

;; return the handle struct for sending queries to a specific database
;;  - initializes the connection object if this is the first access
;;    - finds the "captain" and asks who to talk to for the given dbfname
;;    - establishes the connection to the current dbowner
;;
(define (rmt:connect alldat dbfname dbtype)
#;(define (rmt:connect alldat dbfname dbtype)
  (let* ((ulexdat    (or (alldat-ulexdat alldat)
			 (rmt:setup-ulex alldat))))
    (ulex:connect ulexdat dbfname dbtype)))

;; setup the remote calls
(define (rmt:setup-ulex alldat)
#;(define (rmt:setup-ulex alldat)
  (let* ((udata (ulex:setup))) ;; establish connection to ulex
    (alldat-ulexdat-set! alldat udata)
    ;; register all needed procs
    (ulex:register-handler udata 'ping common:get-full-version)  ;; override ping with get-full-version
    (ulex:register-handler udata 'login common:get-full-version) ;; force setup of the connection
    (ulex:register-handler udata 'execute api:execute-requests)
    udata))

;; set up a connection to the current owner of the dbfile associated with rid
;; then send the query to that dbfile owner and wait for a response.
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (let* ((alldat   *alldat*)
#;(define (rmt:send-receive alldat cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (let* (;; (alldat   *alldat*)
	 (areapath (alldat-areapath alldat))
	 (dbtype   (if (or (not rid)(< rid 1)) ;; this is the criteria for "main.db"
		       "main" "runs"))
	 (dbfname  (if (equal? dbtype "main")
		       "main.db"
		       (conc rid ".db")))
	 (dbfile   (conc areapath "/.db/" dbfname))
︙

Modified runs.scm from [a12d4265e8] to [70ec443715].

︙
530
531
532
533
534
535
536









537
538
539
540
541
542
543

530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552








+
+
+
+
+
+
+
+
+








    (runs:update-all-test_meta #f)

    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    ;; mark all test launced flag as false in the meta table 
    (rmt:set-var (conc "lunch-complete-" run-id) "no")
    (debug:print-info 1 *default-log-port* "Setting end-of-run to no")
    (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	  (config-rerun-cnt (if config-reruns
			config-reruns
			1)))
    (if (eq? config-rerun-cnt run-count)
      (rmt:set-var (conc "end-of-run-" run-id) "no")))

    (rmt:set-run-state-status run-id "new" "n/a")
    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;
︙
683
684
685
686
687
688
689
690


691
692
693
694

695
696
697
698
699
700

701
702
703
704
705
706
707

692
693
694
695
696
697
698

699
700
701
702
703

704


705
706
707
708
709
710
711
712
713
714
715
716








-
+
+



-
+
-
-




+








	    (if (> run-count 0) ;; handle reruns
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
		  ;; recursive call to self
      (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
      (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
                  (launch:end-of-run-check run-id)))
	  (debug:print-info 0 *default-log-port* "No tests to run")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here
    ;(if (eq? run-count 0)
      
    ; (begin  
    ;  (debug:print-info 0 *default-log-port* "Calling Post Hook")  
    ;  (debug:print-info 2 *default-log-port* " run-count " run-count)
    ;  (runs:run-post-hook run-id))
    ;  (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   
    (rmt:tasks-set-state-given-param-key task-key "done")
     
    ;; (sqlite3:finalize! tasks-db)
    ))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
︙
1676
1677
1678
1679
1680
1681
1682
1683
1684


1685
1686
1687
1688
1689
1690
1691

1685
1686
1687
1688
1689
1690
1691


1692
1693
1694
1695
1696
1697
1698
1699
1700








-
-
+
+








	  (debug:print-info 0 *default-log-port* "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; end loop on sorted test names
    ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched 
    (rmt:set-var (conc "lunch-complete-" run-id) "yes")
  
    (rmt:set-var (conc "lunch-complete-" run-id) "yes")  
        
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
︙
2363
2364
2365
2366
2367
2368
2369






2370
2371
2372
2373
2374
2375
2376

2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391








+
+
+
+
+
+








                                          )
                                          (begin
                                            (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
                                            (debug:print 2 *default-log-port* "Is /tmp/badname: " (string=  rundir "/tmp/badname"))
                                            (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir))
                                            (debug:print 2 *default-log-port* "Has run-name: " (substring-index run-name rundir))
                                            (debug:print 2 *default-log-port* "Has target: " (substring-index target rundir))
                                            ;;PJH remove record from db no need to cleanup directory
                                            (case mode
                                               ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f))
                                               ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
                                               (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))

                                          )
                                        )
                                      )

                                      (if (not (null? tal))
                                         (loop (car tal)(cdr tal)))))))
				(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
︙
2457
2458
2459
2460
2461
2462
2463


2464
2465


2466
2467
2468
2469
2470
2471
2472

2472
2473
2474
2475
2476
2477
2478
2479
2480


2481
2482
2483
2484
2485
2486
2487
2488
2489








+
+
-
-
+
+








                    (debug:print 1 *default-log-port* "Removing target " target "run: " run-name)
                    (if (not keep-records)
                      (begin
                        (debug:print 1 *default-log-port* "Removing DB records for the run.")
                        (rmt:delete-run run-id)
                        (rmt:delete-old-deleted-test-records))
                    )
                    (if (not (equal?  linkspath "/does/not/exist/I"))
	               (begin 
	           (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
                   (runs:recursive-delete-with-error-msg linkspath)
                         (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
                         (runs:recursive-delete-with-error-msg linkspath)))

                   (for-each (lambda(runpath)
                       (debug:print 1 *default-log-port* "Recursively removing runs dir " runpath)
                       (runs:recursive-delete-with-error-msg runpath)
                     )
                     runpaths
                   )
︙
2733
2734
2735
2736
2737
2738
2739
2740

2741
2742
2743
2744
2745
2746





2747
2748
2749
2750

2751
2752
2753
2754
2755
2756
2757
2758
2759

2750
2751
2752
2753
2754
2755
2756

2757
2758





2759
2760
2761
2762
2763
2764
2765
2766

2767


2768
2769
2770
2771
2772
2773
2774








-
+

-
-
-
-
-
+
+
+
+
+



-
+
-
-








(define doc-template 
  '(*TOP*
    (*PI* xml "version='1.0'")
    (testsuite)))

(define (runs:update-junit-test-reporter-xml run-id)
  (let*	(
	 (junit-test-reporter	 (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
	 (junit-test-reporter	(configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
	 (junit-test-report-dir  (configf:lookup *configdat* "runs" "junit-test-report-dir"))
	 (xml-dir		 (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
				     (if junit-test-report-dir
					 junit-test-report-dir
					 (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
				     #f))
	 (xml-dir		(if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
				    (if junit-test-report-dir
					junit-test-report-dir
					(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
				    #f))
	 (xml-ts-name		(if xml-dir
				    (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
				    #f))
         (keyname               (if xml-ts-name
         (keyname               (if xml-ts-name (common:get-signature xml-ts-name) #f))
				    (common:get-signature xml-ts-name)
				    #f))
	 (xml-path		(if xml-dir
				    (conc xml-dir "/" keyname ".xml")
				    #f))

	 (test-data		(if xml-dir
				    (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
							   #f #f ;; offset limit
︙

This page was generated in about 0.171s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00