︙ | | | ︙ | |
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs)))
(let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
(exit 1))))
(instr2 (if config
(config-lookup config "requirements" "waitor")
|
|
|
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs)))
(let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
(exit 1))))
(instr2 (if config
(config-lookup config "requirements" "waitor")
|
︙ | | | ︙ | |
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
|
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))
(test-rundir ;; (sdb:qry 'passstr
(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%")
|
|
|
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
|
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))
(test-rundir ;; (sdb:qry 'passstr
(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%")
|
︙ | | | ︙ | |
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
|
(if (null? tal)
#t
(loop (car tal)(cdr tal)))
#f))))))
(pop-directory)
result)))))
(define (tests:test-force-state-status! run-id test-id state status)
(rmt:test-set-status-state run-id test-id status state #f)
;; (rmt:roll-up-pass-fail-counts run-id test-name item
(mt:process-triggers run-id test-id state status))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f))
(let* ((real-status status)
(otherdat (if dat dat (make-hash-table)))
(testdat (rmt:get-test-info-by-id run-id test-id))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
|
<
<
<
<
<
|
349
350
351
352
353
354
355
356
357
358
359
360
361
362
|
(if (null? tal)
#t
(loop (car tal)(cdr tal)))
#f))))))
(pop-directory)
result)))))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f))
(let* ((real-status status)
(otherdat (if dat dat (make-hash-table)))
(testdat (rmt:get-test-info-by-id run-id test-id))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
|
︙ | | | ︙ | |
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
(set! real-status "WAIVED"))
(debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
(rmt:test-set-status-state run-id test-id real-status state (if waived waived comment))
;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-status-state
))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, it does remote calls under the hood.
;; (if (and test-id state status (equal? status "AUTO"))
;; (rmt:test-data-rollup run-id test-id status))
|
|
|
|
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
(set! real-status "WAIVED"))
(debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
(rmt:set-state-status-and-roll-up-items run-id test-id item-path state real-status (if waived waived comment))
;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-state-status
))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, it does remote calls under the hood.
;; (if (and test-id state status (equal? status "AUTO"))
;; (rmt:test-data-rollup run-id test-id status))
|
︙ | | | ︙ | |
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
|
dcomment ",," ;; extra comma for status
type )))
;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
(rmt:csv->test-data run-id test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (not (equal? item-path ""))
(rmt:roll-up-pass-fail-counts run-id test-name item-path state status #f))
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
(rmt:general-call 'set-test-comment run-id cmt test-id)))))
|
|
|
|
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
|
dcomment ",," ;; extra comma for status
type )))
;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
(rmt:csv->test-data run-id test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
;;;;;; (if (not (equal? item-path ""))
;;;;;; (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;)
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
(rmt:general-call 'set-test-comment run-id cmt test-id)))))
|
︙ | | | ︙ | |
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
|
force)
(let ((my-start-time (current-seconds))
(lockf (conc outputfilename ".lock")))
(let loop ((have-lock (common:simple-file-lock lockf)))
(if have-lock
(let ((script (configf:lookup *configdat* "testrollup" test-name)))
(print "Obtained lock for " outputfilename)
(rmt:roll-up-pass-fail-counts run-id test-name "" #f #f #f)
;; (rmt:test-set-status-state run-id test-name #f #f #f) ;; (rmt:top-test-set-per-pf-counts run-id test-name)
(if script
(system (conc script " > " outputfilename " & "))
(tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename))
(common:simple-file-release-lock lockf)
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
(tests:test-set-toplog! run-id test-name outputfilename))
|
|
<
|
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
|
force)
(let ((my-start-time (current-seconds))
(lockf (conc outputfilename ".lock")))
(let loop ((have-lock (common:simple-file-lock lockf)))
(if have-lock
(let ((script (configf:lookup *configdat* "testrollup" test-name)))
(print "Obtained lock for " outputfilename)
(rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f)
(if script
(system (conc script " > " outputfilename " & "))
(tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename))
(common:simple-file-release-lock lockf)
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
(tests:test-set-toplog! run-id test-name outputfilename))
|
︙ | | | ︙ | |
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
|
#f))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;; if have path to test directory save the config as .testconfig and return it
;;
(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f))
(let* ((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)
(handle-exceptions
exn
#f ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
#f)))
(if cached-dat
cached-dat
(let ((dat (hash-table-ref/default *testconfigs* test-name #f)))
(if (and dat ;; have a locally cached version
(hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data?
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
(if tcfg (hash-table-set! *testconfigs* test-name tcfg))
(if (and testexists
cache-file
(file-write-access? cache-path))
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
(configf:write-alist tcfg tpath)))
tcfg))))))
|
|
|
>
>
>
|
|
|
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
|
#f))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;; if have path to test directory save the config as .testconfig and return it
;;
(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f))
(let* ((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)
(handle-exceptions
exn
#f ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
#f))
(test-full-name (if (and item-path (not (string-null? item-path)))
(conc test-name "/" item-path)
test-name)))
(if cached-dat
cached-dat
(let ((dat (hash-table-ref/default *testconfigs* test-full-name #f)))
(if (and dat ;; have a locally cached version
(hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data?
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
(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
(if (and testexists
cache-file
(file-write-access? cache-path))
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
(configf:write-alist tcfg tpath)))
tcfg))))))
|
︙ | | | ︙ | |
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
|
;; hed is the test name
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests all-tests-registry)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")
(let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
(debug:print-info 8 *default-log-port* "waitons string is " instr)
(string-split (cond
|
>
|
|
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
|
;; hed is the test name
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests all-tests-registry)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")
;; don't know item-path at this time, let the testconfig get the top level testconfig
(let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
(debug:print-info 8 *default-log-port* "waitons string is " instr)
(string-split (cond
|
︙ | | | ︙ | |