Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -156,10 +156,17 @@ mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm +ext-tests/.fslckout : $(MTQA_FOSSIL) + mkdir -p ext-tests + cd ext-tests;fossil open --nested $(MTQA_FOSSIL) + +$(MTQA_FOSSIL) : + fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) + clean : rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o # Deploy section (not complete yet) # Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -3268,19 +3268,20 @@ ;;====================================================================== ;; A routine to map itempaths using a itemmap ;; patha and pathb must be strings or this will fail ;; -(define (db:compare-itempaths patha pathb itemmaps) +;; path-b is waiting on path-a +;; +(define (db:compare-itempaths test-b-name path-a path-b itemmaps ) (debug:print-info 6 "ITEMMAPS: " itemmaps) - (let* ((testname-a (car (string-split patha "/"))) - (itemmap (tests:lookup-itemmap itemmaps testname-a))) + (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name))) (if itemmap - (let ((pathb-mapped (db:multi-pattern-apply pathb itemmap))) - (debug:print-info 6 "ITEMMAP is " itemmap ", path: " pathb ", mapped path: " pathb-mapped) - (equal? patha pathb-mapped)) - (equal? patha pathb)))) + (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap))) + (debug:print-info 6 "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped) + (equal? path-a path-b-mapped)) + (equal? path-b path-a)))) ;; A routine to convert test/itempath using a itemmap ;; NOTE: to process only an itempath (i.e. no prepended testname) ;; just call db:multi-pattern-apply ;; @@ -3324,11 +3325,11 @@ ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) -(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) +(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) @@ -3349,11 +3350,12 @@ (item-path (db:test-get-item-path test)) (is-completed (equal? state "COMPLETED")) (is-running (equal? state "RUNNING")) (is-killed (equal? state "KILLED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - (same-itempath (db:compare-itempaths item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) + ;; testname-b path-a path-b + (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) (set! ever-seen #t) (cond ;; case 1, non-item (parent test) is ((and (equal? item-path "") ;; this is the parent test of the waiton being examined is-completed 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 @@ -561,11 +561,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 +749,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))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -94,11 +94,11 @@ ;; 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)))) 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))