Overview
Context
Changes
Modified dashboard-tests.scm
from [df43bcce90]
to [0bfb3e05a8].
︙ | | |
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
|
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
|
-
-
+
+
+
+
+
+
+
|
(vector-ref x 4)
(vector-ref x 5))) ;; time delta
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1)))
(if (and (number? time-a)(number? time-b))
(< time-a time-b)
#t))))))
(if (< time-a time-b)
#t
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b))))))))
"\n")))
(if (not (equal? currval newval))
(iup:attribute-set! stepsdat "VALUE" newval ))))) ;; "TITLE" newval)))))
stepsdat))
;; populate the Test Data panel
(iup:frame
#:title "Test Data"
|
︙ | | |
Modified db.scm
from [f398e4db4e]
to [340b92637a].
︙ | | |
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
|
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
|
-
-
-
-
+
+
+
+
+
|
"\nid: " (db:step-get-id step)
"\nstepname: " (db:step-get-stepname step)
"\nstate: " (db:step-get-state step)
"\nstatus: " (db:step-get-status step)
"\ntime: " (db:step-get-event_time step))))
;; (else (vector-set! record 1 (db:step-get-event_time step)))
(sort steps (lambda (a b)
(< (db:step-get-event_time a)(db:step-get-event_time b))
)))
(cond
((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
((eq? (db:step-get-event_time a)(db:step-get-event_time b))
(< (db:step-get-id a) (db:step-get-id b)))
(else #f)))))
res)))
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
;; the new prereqs calculation, looks also at itempath if specified
|
︙ | | |
Modified launch.scm
from [a7c83cebbb]
to [dd3e168314].
︙ | | |
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
|
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
|
-
+
-
+
+
+
+
+
+
+
+
+
|
'())))
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd)))))
(setenv "MT_CMDINFO" encoded-cmd)
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
(let* ((testpath (assoc/default 'testpath cmdinfo))
(let* ((testpath (assoc/default 'testpath cmdinfo)) ;; How is testpath different from work-area ??
(top-path (assoc/default 'toppath cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(ezsteps (assoc/default 'ezsteps cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(target (assoc/default 'target cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(env-ovrd (assoc/default 'env-ovrd cmdinfo))
(set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar
(runname (assoc/default 'runname cmdinfo))
(megatest (assoc/default 'megatest cmdinfo))
(mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
(fullrunscript (if runscript (conc testpath "/" runscript) #f))
(fullrunscript (if (not runscript)
#f
(if (substring-index "/" runscript)
runscript ;; use unadultered if contains slashes
(let ((fulln (conc testpath "/" runscript)))
(if (and (file-exists? fulln)
(file-execute-access? fulln))
fulln
runscript))))) ;; assume it is on the path
(rollup-status 0))
(debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
;; apply pre-overrides before other variables. The pre-override vars must not
;; clobbers things from the official sources such as megatest.config and runconfigs.config
(if (string? set-vars)
(let ((varpairs (string-split set-vars ",")))
|
︙ | | |
Modified megatest.scm
from [a0e0e04587]
to [43202ebdc8].
︙ | | |
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
-
+
|
Examples
# Get test path, use '.' to get a single path or a specific path/file pattern
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% :runname w49% -testpatt test_mt%
Called as " (string-intersperse (argv) " ") "
Built from " megatest-fossil-hash ))
Version " megatest-version ", built from " megatest-fossil-hash ))
;; -gui : start a gui interface
;; -config fname : override the runconfig file with fname
;; -kill-server host:port|pid : kill server specified by host:port or pid
;; process args
(define remargs (args:get-args
|
︙ | | |
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
|
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
|
-
-
+
+
-
|
(if (args:get-arg "-runall")
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keynames keyvallst)
(runs:run-tests target
runname
(if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"
(args:get-arg "-testpatt")
"%/%")
user
args:arg-hash))))
;;======================================================================
;; run one test
;;======================================================================
|
︙ | | |
500
501
502
503
504
505
506
507
508
509
510
511
512
513
|
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
|
+
|
(general-run-call
"-runtests"
"run a test"
(lambda (target runname keys keynames keyvallst)
(runs:run-tests target
runname
(args:get-arg "-runtests")
(args:get-arg "-testpatt")
user
args:arg-hash))))
;;======================================================================
;; Rollup into a run
;;======================================================================
|
︙ | | |
Modified runs.scm
from [6923ee1d25]
to [ac5e3e62fc].
︙ | | |
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
|
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
|
-
-
+
+
+
+
+
+
+
-
-
+
|
(sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res)
res)
(begin
(debug:print 0 "ERROR: Called without all necessary keys")
#f))))
;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
;; keyvals
(define (runs:run-tests target runname test-patts user flags)
;; keyvals.
;;
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-names test-patts user flags)
(let* ((db #f)
(keys (cdb:remote-run db:get-keys #f))
(keyvallst (keys:target->keyval keys target))
(run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(test-names '())
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table)))
(set-megatest-env-vars run-id) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
(set! test-names (tests:get-valid-tests *toppath* test-patts test-names: test-names))
(set! test-names (tests:get-valid-tests *toppath* test-names))
(set! test-names (delete-duplicates test-names))
(debug:print-info 0 "test names " test-names)
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (eq? *passnum* 0)
|
︙ | | |
Modified tests.scm
from [4543da4028]
to [661a4dba80].
︙ | | |
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
-
+
-
-
-
-
-
-
+
+
+
+
+
|
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(define (tests:get-valid-tests testsdir test-patts #!key (test-names '()))
(define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
(let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
(set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
(delete-duplicates
(append test-names
(filter (lambda (testname)
(tests:match test-patts testname #f))
(map (lambda (testp)
(last (string-split testp "/")))
tests))))))
(filter (lambda (testname)
(tests:match test-patts testname #f))
(map (lambda (testp)
(last (string-split testp "/")))
tests)))))
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
(let* ((notpatt (equal? (substring-index "~" patt) 0))
(newpatt (if notpatt (substring patt 1) patt))
(finpatt (if like
|
︙ | | |
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
|
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
|
-
+
|
(print "Obtained lock for " outputfilename)
(print "Failed to obtain lock for " outputfilename))
(let ((oup (open-output-file outputfilename))
(counts (make-hash-table))
(statecounts (make-hash-table))
(outtxt "")
(tot 0)
(testdat (cdb:remote-run db:test-get-records-for-index-file run-id test-name)))
(testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name)))
(with-output-to-port
oup
(lambda ()
(set! outtxt (conc outtxt "<html><title>Summary: " test-name
"</title><body><h2>Summary for " test-name "</h2>"))
(for-each
(lambda (testrecord)
|
︙ | | |