Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -32,41 +32,14 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "megatest-fossil-hash.scm") -;; (use trace dot-locking) -;; (trace -;; tests:match -;; runs:run-tests) -;; db:teststep-set-status! -;; db:open-test-db-by-test-id -;; db:test-get-rundir-from-test-id -;; cdb:tests-register-test -;; cdb:tests-update-uname-host -;; cdb:tests-update-run-duration -;; ;; cdb:client-call -;; ;; cdb:remote-run -;; ) -;; cdb:test-set-status-state -;; change-directory -;; db:process-queue-item -;; db:test-get-logfile-info -;; db:teststep-set-status! -;; nice-path -;; obtain-dot-lock -;; open-run-close -;; read-config -;; runs:can-run-more-tests -;; sqlite3:execute -;; sqlite3:for-each-row -;; tests:check-waiver-eligibility -;; tests:summarize-items -;; tests:test-set-status! -;; thread-sleep! -;;) - +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -411,28 +384,32 @@ (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) + +(define (full-runconfigs-read) + (let* ((keys (cdb:remote-run get-keys #f)) + (target (if (args:get-arg "-reqtarg") + (args:get-arg "-reqtarg") + (if (args:get-arg "-target") + (args:get-arg "-target") + #f))) + (key-vals (if target (keys:target->keyval keys target) #f)) + (sections (if target (list "default" target) #f)) + (data (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (if key-vals + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals)) + (read-config "runconfigs.config" #f #t sections: sections)))) + data)) + (if (args:get-arg "-show-runconfig") - (let* ((keys (cdb:remote-run get-keys #f)) - (target (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - #f))) - (key-vals (if target (keys:target->keyval keys target) #f)) - (sections (if target (list "default" target) #f)) - (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (if key-vals - (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) - key-vals)) - (read-config "runconfigs.config" #f #t sections: sections)))) - + (let ((data (full-runconfigs-read))) ;; keep this one local (cond ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") Index: run-tests-queue-classic.scm ================================================================== --- run-tests-queue-classic.scm +++ run-tests-queue-classic.scm @@ -1,8 +1,8 @@ ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts) +(define (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts required-tests) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) (key-vals (cdb:remote-run db:get-key-vals #f run-id)) @@ -52,13 +52,13 @@ (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) + (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) (not (null? tal))) - (loop (car tal)(cdr tal) reruns)) + (loop (car newtal)(cdr newtal) reruns)) (let* ((run-limits-info (runs:can-run-more-tests test-record max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (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)) @@ -78,11 +78,11 @@ ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? (debug:print-info 4 "run-limits-info = " run-limits-info) (cond ;; INNER COND #1 for a launchable test ;; Check item path against item-patts - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run + ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) @@ -178,11 +178,11 @@ (lambda (my-itemdat) (let* ((new-test-record (let ((newrec (make-tests:testqueue))) (vector-copy! test-record newrec) newrec)) (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! + (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) (tests:testqueue-set-itemdat! new-test-record my-itemdat) (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) Index: run-tests-queue-new.scm ================================================================== --- run-tests-queue-new.scm +++ run-tests-queue-new.scm @@ -1,8 +1,8 @@ ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen) +(define (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts required-tests reglen) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) (key-vals (cdb:remote-run db:get-key-vals #f run-id)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -165,11 +165,12 @@ (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)) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) - (test-records (make-hash-table))) + (test-records (make-hash-table)) + (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names) (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") @@ -207,19 +208,27 @@ (begin ;; No config means this is a non-existant test (debug:print 0 "ERROR: non-existent required test \"" hed "\"") (if db (sqlite3:finalize! db)) (exit 1))))) (debug:print-info 8 "waitons string is " instr) - (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) - "")))))) + (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 (member x all-test-names) + #t + (begin + (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x) + #f))) + newwaitons))))) (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) (begin @@ -275,12 +284,12 @@ (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (any->number (configf:lookup *configdat* "setup" "runqueue")))) (if reglen - (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen) - (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts))) + (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts required-tests reglen) + (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts required-tests))) (debug:print-info 4 "All done by here"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) @@ -627,11 +636,11 @@ ;; )) (set! keys (open-run-close db:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL - (runconfig (read-config runconfigf #f #t environ-patt: #f))) + (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) (if db (sqlite3:finalize! db)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -51,13 +51,13 @@ (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) ;; if itempath is #f then look only at the testname part ;; -(define (tests:match patterns testname itempath) +(define (tests:match patterns testname itempath #!key (required '())) (if (string? patterns) - (let ((patts (string-split patterns ","))) + (let ((patts (append (string-split patterns ",") required))) (if (null? patts) ;;; no pattern(s) means no match #f (let loop ((patt (car patts)) (tal (cdr patts))) ;; (print "loop: patt: " patt ", tal " tal)