| ︙ | | | ︙ | |
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
(append paths (list (conc *toppath* "/tests"))))))
(define (tests:get-valid-tests test-registry tests-paths)
(if (null? tests-paths)
test-registry
(let loop ((hed (car tests-paths))
(tal (cdr tests-paths)))
(if (common:file-exists? hed)
(for-each (lambda (test-path)
(let* ((tname (last (string-split test-path "/")))
(tconfig (conc test-path "/testconfig")))
(if (and (not (hash-table-ref/default test-registry tname #f))
(common:file-exists? tconfig))
(hash-table-set! test-registry tname test-path))))
(glob (conc hed "/*"))))
(if (null? tal)
test-registry
(loop (car tal)(cdr tal))))))
(define (tests:filter-test-names-not-matched test-names test-patts)
|
|
|
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
(append paths (list (conc *toppath* "/tests"))))))
(define (tests:get-valid-tests test-registry tests-paths)
(if (null? tests-paths)
test-registry
(let loop ((hed (car tests-paths))
(tal (cdr tests-paths)))
(if (file-exists? hed)
(for-each (lambda (test-path)
(let* ((tname (last (string-split test-path "/")))
(tconfig (conc test-path "/testconfig")))
(if (and (not (hash-table-ref/default test-registry tname #f))
(file-exists? tconfig))
(hash-table-set! test-registry tname test-path))))
(glob (conc hed "/*"))))
(if (null? tal)
test-registry
(loop (car tal)(cdr tal))))))
(define (tests:filter-test-names-not-matched test-names test-patts)
|
| ︙ | | | ︙ | |
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
377
378
379
|
(db:test-get-rundir testdat)) ;; )
(prev-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir prev-testdat)) ;; )
(waivers (if testconfig (configf:section-vars testconfig "waivers") '()))
(waiver-rx (regexp "^(\\S+)\\s+(.*)$"))
(diff-rule "diff %file1% %file2%")
(logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
(if (not (common:file-exists? test-rundir))
(begin
(debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver")
#f)
(begin
(push-directory test-rundir)
(let ((result (if (null? waivers)
#f
(let loop ((hed (car waivers))
(tal (cdr waivers)))
(debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"")
(let* ((waiver (configf:lookup testconfig "waivers" hed))
(wparts (if waiver (string-match waiver-rx waiver) #f))
(waiver-rule (if wparts (cadr wparts) #f))
(waiver-glob (if wparts (caddr wparts) #f))
(logpro-file (if waiver
(let ((fname (conc hed ".logpro")))
(if (common:file-exists? fname)
fname
(begin
(debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff")
#f)))
#f))
;; if rule by name of waiver-rule is found in testconfig - use it
;; else if waivername.logpro exists use logpro-rule
|
|
|
|
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
377
378
379
|
(db:test-get-rundir testdat)) ;; )
(prev-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir prev-testdat)) ;; )
(waivers (if testconfig (configf:section-vars testconfig "waivers") '()))
(waiver-rx (regexp "^(\\S+)\\s+(.*)$"))
(diff-rule "diff %file1% %file2%")
(logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
(if (not (file-exists? test-rundir))
(begin
(debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver")
#f)
(begin
(push-directory test-rundir)
(let ((result (if (null? waivers)
#f
(let loop ((hed (car waivers))
(tal (cdr waivers)))
(debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"")
(let* ((waiver (configf:lookup testconfig "waivers" hed))
(wparts (if waiver (string-match waiver-rx waiver) #f))
(waiver-rule (if wparts (cadr wparts) #f))
(waiver-glob (if wparts (caddr wparts) #f))
(logpro-file (if waiver
(let ((fname (conc hed ".logpro")))
(if (file-exists? fname)
fname
(begin
(debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff")
#f)))
#f))
;; if rule by name of waiver-rule is found in testconfig - use it
;; else if waivername.logpro exists use logpro-rule
|
| ︙ | | | ︙ | |
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
|
"Runs"
(common:htree->html runs-htree
'()
(lambda (x p)
(let* ((targ-path (string-intersperse p "/"))
(full-path (conc linktree "/" targ-path))
(run-name (car (reverse p))))
(if (and (common:file-exists? full-path)
(directory? full-path)
(file-write-access? full-path))
(s:a run-name 'href (conc targ-path "/run-summary.html"))
(begin
(debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
(conc run-name " (Not able to create summary at " targ-path ")")))))))))))
(close-output-port oup)
|
|
|
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
|
"Runs"
(common:htree->html runs-htree
'()
(lambda (x p)
(let* ((targ-path (string-intersperse p "/"))
(full-path (conc linktree "/" targ-path))
(run-name (car (reverse p))))
(if (and (file-exists? full-path)
(directory? full-path)
(file-write-access? full-path))
(s:a run-name 'href (conc targ-path "/run-summary.html"))
(begin
(debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
(conc run-name " (Not able to create summary at " targ-path ")")))))))))))
(close-output-port oup)
|
| ︙ | | | ︙ | |
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
|
(full-name (db:test-make-full-name test-name item-path))
(path-parts (string-split full-name)))
path-parts))
test-dats))
(tests-htree (common:list->htree tests-tree-dat))
(html-dir (conc linktree "/" (string-intersperse run-dir "/")))
(html-path (conc html-dir "/run-summary.html"))
(oup (if (and (common:file-exists? html-dir)
(directory? html-dir)
(file-write-access? html-dir))
(open-output-file html-path)
#f)))
;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
(if oup
(begin
|
|
|
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
|
(full-name (db:test-make-full-name test-name item-path))
(path-parts (string-split full-name)))
path-parts))
test-dats))
(tests-htree (common:list->htree tests-tree-dat))
(html-dir (conc linktree "/" (string-intersperse run-dir "/")))
(html-path (conc html-dir "/run-summary.html"))
(oup (if (and (file-exists? html-dir)
(directory? html-dir)
(file-write-access? html-dir))
(open-output-file html-path)
#f)))
;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
(if oup
(begin
|
| ︙ | | | ︙ | |
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
|
(let* ((targ-path (string-intersperse p "/"))
(test-name (car p))
(item-path ;; (if (> (length p) 2) ;; test-name + run-name
(string-intersperse p "/"))
(full-targ (conc html-dir "/" targ-path))
(std-file (conc full-targ "/test-summary.html"))
(alt-file (conc full-targ "/megatest-rollup-" test-name ".html"))
(html-file (if (common:file-exists? alt-file)
alt-file
std-file))
(run-name (car (reverse p))))
(if (and (not (common:file-exists? full-targ))
(directory? full-targ)
(file-write-access? full-targ))
(tests:summarize-test
run-id
(rmt:get-test-id run-id test-name item-path)))
(if (common:file-exists? full-targ)
(s:a run-name 'href html-file)
(begin
(debug:print 0 *default-log-port* "ERROR: can't access " full-targ)
(conc "No summary for " run-name)))))
))))))
(close-output-port oup)))))
runs)
|
|
|
|
|
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
|
(let* ((targ-path (string-intersperse p "/"))
(test-name (car p))
(item-path ;; (if (> (length p) 2) ;; test-name + run-name
(string-intersperse p "/"))
(full-targ (conc html-dir "/" targ-path))
(std-file (conc full-targ "/test-summary.html"))
(alt-file (conc full-targ "/megatest-rollup-" test-name ".html"))
(html-file (if (file-exists? alt-file)
alt-file
std-file))
(run-name (car (reverse p))))
(if (and (not (file-exists? full-targ))
(directory? full-targ)
(file-write-access? full-targ))
(tests:summarize-test
run-id
(rmt:get-test-id run-id test-name item-path)))
(if (file-exists? full-targ)
(s:a run-name 'href html-file)
(begin
(debug:print 0 *default-log-port* "ERROR: can't access " full-targ)
(conc "No summary for " run-name)))))
))))))
(close-output-port oup)))))
runs)
|
| ︙ | | | ︙ | |
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
|
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
;; (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)(common:file-exists? (conc test "/testconfig"))) tests))
;; (delete-duplicates
;; (filter (lambda (testname)
;; (tests:match test-patts testname #f))
;; (map (lambda (testp)
;; (last (string-split testp "/")))
;; tests)))))
|
|
|
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
|
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
;; (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
;; (filter (lambda (testname)
;; (tests:match test-patts testname #f))
;; (map (lambda (testp)
;; (last (string-split testp "/")))
;; tests)))))
|
| ︙ | | | ︙ | |
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
|
;;
(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t))
(let* ((use-cache (common:use-cache?))
(cache-path (tests:get-test-path-from-environment))
(cache-file (and cache-path (conc cache-path "/.testconfig")))
(cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
(common:file-exists? cache-file)))
(cached-dat (if (and (not force-create)
cache-exists
use-cache)
(handle-exceptions
exn
#f ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
|
|
|
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
|
;;
(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t))
(let* ((use-cache (common:use-cache?))
(cache-path (tests:get-test-path-from-environment))
(cache-file (and cache-path (conc cache-path "/.testconfig")))
(cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
(file-exists? cache-file)))
(cached-dat (if (and (not force-create)
cache-exists
use-cache)
(handle-exceptions
exn
#f ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
|
| ︙ | | | ︙ | |
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
|
dat
;; no cached data available
(let* ((treg (or test-registry
(tests:get-all)))
(test-path (or (hash-table-ref/default treg test-name #f)
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (and (common:file-exists? test-configf)(file-read-access? test-configf)))
(tcfg (if testexists
(read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
|
|
|
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
|
dat
;; no cached data available
(let* ((treg (or test-registry
(tests:get-all)))
(test-path (or (hash-table-ref/default treg test-name #f)
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
(tcfg (if testexists
(read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
|
| ︙ | | | ︙ | |
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
|
;; read data from tmp file or create if not exists
;; if exists regen in background
;;
(define (tests:lazy-dot testrecords outtype sizex sizey)
(let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
(tests:write-dot-file testrecords dfile sizex sizey)
(if (common:file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
(system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
res)
(begin
(system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))
|
|
|
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
|
;; read data from tmp file or create if not exists
;; if exists regen in background
;;
(define (tests:lazy-dot testrecords outtype sizex sizey)
(let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
(tests:write-dot-file testrecords dfile sizex sizey)
(if (file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
(system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
res)
(begin
(system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))
|
| ︙ | | | ︙ | |