In megatest.config add the following sections:
Index: docs/manual/reference.txt
==================================================================
--- docs/manual/reference.txt
+++ docs/manual/reference.txt
@@ -186,12 +186,11 @@
[requirements]
waiton A B
[itemmap]
A (\d+)/aa aa/\1
-B (\d+)/bb bb/\1
-----------------------
+B (\d+)/bb --------------------
.Testconfig for Test D
----------------------
[requirements]
waiton C
@@ -212,17 +211,18 @@
-------------------
[requirements]
# With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
-# waiton #{shell get-valid-tests-to-run.sh}
+waiton #{shell get-valid-tests-to-run.sh}
-------------------
Run time limit
^^^^^^^^^^^^^^
-----------------
+[requirements]
runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s
-----------------
Skip
^^^^
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -504,12 +504,12 @@
run-ids))))
;; (define (rmt:get-run-ids-matching keynames target res)
;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
-(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f))
- (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode itemmaps)))
+(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
+ (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
(define (rmt:get-count-tests-running-for-run-id run-id)
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
;; Statistical queries
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -349,41 +349,20 @@
(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
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
- (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 0 "ERROR: non-existent required test \"" hed "\"")
- (exit 1)))))
- (debug:print-info 8 "waitons string is " instr)
- (let ((newwaitons
- (string-split (cond
- ((procedure? instr)
- (let ((res (instr)))
- (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
- res))
- ((string? instr) instr)
- (else
- ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
- "")))))
- (filter (lambda (x)
- (if (hash-table-ref/default all-tests-registry x #f)
- #t
- (begin
- (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x)
- #f)))
- newwaitons)))))
+ (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
(debug:print-info 8 "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
- (if (member hed waitons)
+ (if (or (member hed waitons)
+ (member hed waitors))
(begin
- (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
- (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
+ (debug:print 0 "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!")
+ (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
+ (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records
hed (vector hed ;; 0
@@ -414,10 +393,11 @@
" items: " items " itemstable: " itemstable)
(items:get-items-from-config config))
(else #f))) ;; not iterated
#f ;; itemsdat 5
#f ;; spare - used for item-path
+ waitors ;;
)))
(for-each
(lambda (waiton)
(if (and waiton (not (member waiton test-names)))
(let* ((waiton-record (hash-table-ref/default test-records waiton #f))
@@ -459,11 +439,11 @@
;; - doesn't work
;; (set! test-patts (conc test-patts "," waiton "/"))
;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
)))
- waitons)
+ (delete-duplicates (append waitons waitors)))
(let ((remtests (delete-duplicates (append waitons tal))))
(if (not (null? remtests))
(begin
;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
(loop (car remtests)(cdr remtests))))))))
@@ -561,11 +541,11 @@
(define runs:nothing-left-in-queue-count 0)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
(let* ((loop-list (list hed tal reg reruns))
- (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmaps: itemmaps))
+ (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(prereq-fails (runs:calc-prereq-fail prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
(runnables (runs:calc-runnable prereqs-not-met)))
@@ -749,11 +729,11 @@
(have-resources (car run-limits-info))
(num-running (list-ref run-limits-info 1))
(num-running-in-jobgroup (list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
- (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmaps: itemmaps))
+ (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed!
(not (equal? x hed)))
(runs:calc-not-completed prereqs-not-met)))
ADDED supplemental.megatest.config
Index: supplemental.megatest.config
==================================================================
--- /dev/null
+++ supplemental.megatest.config
@@ -0,0 +1,3 @@
+[tests-paths]
+nada #{getenv MT_RUN_AREA_HOME}/moretests
+
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -84,53 +84,111 @@
;;
(define (tests:get-itemmaps tconfig)
(let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap"))
(itemmap-table (configf:get-section tconfig "itemmap")))
(append (if base-itemmap
- (list (cons "%" base-itemmap))
+ (list (list "%" base-itemmap))
'())
(if itemmap-table
itemmap-table
'()))))
;; given a list of itemmaps (testname . map), return the first match
;;
(define (tests:lookup-itemmap itemmaps testname)
(let ((best-matches (filter (lambda (itemmap)
- (tests:match (car itemmap) testname))
+ (tests:match (car itemmap) testname #f))
itemmaps)))
(if (null? best-matches)
#f
- (car best-matches))))
+ (let ((res (car best-matches)))
+ (debug:print 0 "res=" res)
+ (cond
+ ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
+ ((null? res) #f)
+ ((string? (cdr res)) (cdr res)) ;; it is a pair
+ ((string? (cadr res))(cadr res)) ;; it is a list
+ (else cadr res))))))
+
+;; 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 0 "ERROR: non-existent required test \"" test-name "\"")
+ (exit 1))))
+ (instr2 (if config
+ (config-lookup config "requirements" "waitor")
+ "")))
+ (debug:print-info 8 "waitons string is " instr ", waitors string is " instr2)
+ (let ((newwaitons
+ (string-split (cond
+ ((procedure? instr)
+ (let ((res (instr)))
+ (debug:print-info 8 "waiton procedure results in string " res " for test " test-name)
+ res))
+ ((string? instr) instr)
+ (else
+ ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
+ ""))))
+ (newwaitors
+ (string-split (cond
+ ((procedure? instr2)
+ (let ((res (instr2)))
+ (debug:print-info 8 "waitor procedure results in string " res " for test " test-name)
+ res))
+ ((string? instr2) instr2)
+ (else
+ ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
+ "")))))
+ (values
+ ;; the waitons
+ (filter (lambda (x)
+ (if (hash-table-ref/default all-tests-registry x #f)
+ #t
+ (begin
+ (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
+ #f)))
+ newwaitons)
+ (filter (lambda (x)
+ (if (hash-table-ref/default all-tests-registry x #f)
+ #t
+ (begin
+ (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
+ #f)))
+ newwaitors)
+ config)))))
-;; given test-b that is waiting on test-a extend test-patt appropriately
+;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
;;
;; genlib/testconfig sim/testconfig
;; genlib/sch sim/sch/cell1
;;
;; [requirements] [requirements]
;; mode itemwait
;; # trim off the cell to determine what to run for genlib
;; itemmap /.*
;;
-;; test-a is waiting on test-b so we need to create a pattern for test-b given test-a and itemmap
-(define (tests:extend-test-patts test-patt test-b test-a itemmaps)
- (let* ((itemmap (tests:lookup-itemmap itemmaps test-b))
- (patts (string-split test-patt ","))
- (test-b-len (+ (string-length test-b) 1))
- (patts-b (map (lambda (x)
- (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x))
- (newpatt (conc test-a "/" (substring modpatt test-b-len (string-length modpatt)))))
- ;; (conc test-a "/," test-a "/" (substring modpatt test-b-len (string-length modpatt)))))
- ;; (print "in map, x=" x ", newpatt=" newpatt)
- newpatt))
- (filter (lambda (x)
- (eq? (substring-index (conc test-b "/") x) 0))
- patts))))
- (string-intersperse (delete-duplicates (append patts (if (null? patts-b)
- (list (conc test-a "/%"))
- patts-b)))
+;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
+(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps)
+ (let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test))
+ (patts (string-split test-patt ","))
+ (waiting-test-len (+ (string-length waiting-test) 1))
+ (patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test
+ (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x))
+ (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
+ ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
+ ;; (print "in map, x=" x ", newpatt=" newpatt)
+ newpatt))
+ (filter (lambda (x)
+ (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
+ patts))))
+ (string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
+ (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
+ patts-waiton)))
",")))
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
Index: tests/tests.scm
==================================================================
--- tests/tests.scm
+++ tests/tests.scm
@@ -10,10 +10,12 @@
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(require-extension test)
(require-extension regex)
(require-extension srfi-18)
+(require-extension posix)
+(import posix)
(import srfi-18)
;; (require-extension zmq)
;; (import zmq)
(define test-work-dir (current-directory))