Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -969,10 +969,14 @@ ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond + ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig + (if rconf + (runconfigs-get rconf testpatt-key) + #f)) ;; We do NOT fall back to "%" ;; (tags-testpatt ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) ;; tags-testpatt) ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -520,10 +520,19 @@ (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt)))))) + +(define (val-alist->areas val-alist) + (string-split (or (alist-ref 'areas val-alist) "") ",")) + +(define (area-allowed? area areas) + (or (not areas) + (null? areas) + (member area areas))) + ;; (use trace)(trace create-run-pkt) ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (generate-run-pkts mtconf toppath) @@ -594,10 +603,11 @@ (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist) (let* ((run-name (alist-ref 'run-name val-alist)) (target (alist-ref 'target val-alist)) (crontab (alist-ref 'cron val-alist)) + (areas (val-alist->areas val-alist)) ;; (action (alist-ref 'action val-alist)) (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X")) (runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))) ;; (print "last-run: " last-run " need-run: " need-run) ;; (if need-run @@ -615,10 +625,17 @@ `((message . ,(conc ruletype ":" cron-safe-string)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) (target . ,target))))) + ((remove) + (push-run-spec torun contour runkey + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) + (runtrans . ,runtrans) + (action . ,action) + (target . ,target)))) (else (print "ERROR: action \"" action "\" has no scheduled handler") ))))) ((script) @@ -694,10 +711,11 @@ (print "Got datetime=" datetime " node=" node)))) val-alist)) ((file file-or) ;; one or more files must be newer than the reference (let* ((file-globs (alist-ref 'glob val-alist)) + (areas (val-alist->areas val-alist)) (youngestdat (common:get-youngest (common:bash-glob file-globs))) (youngestmod (car youngestdat))) ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) (if (null? starttimes) ;; this target has never been run (push-run-spec torun contour runkey @@ -760,11 +778,11 @@ (for-each (lambda (contour) (print "contour: " contour) (let* ((val (or (configf:lookup mtconf "contours" contour) "")) (val-alist (val->alist val)) - (areas (string-split (or (alist-ref 'areas val-alist) "") ",")) + (areas (val-alist->areas val-alist)) (selector (alist-ref 'selector val-alist)) (mode-tag (and selector (string-split-fields "/" selector #:infix))) (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) (for-each @@ -774,28 +792,30 @@ (runkeydats (cadr runkeydatset))) (for-each (lambda (runkeydat) (for-each (lambda (area) - (let ((runname (alist-ref 'runname runkeydat)) - (runtrans (alist-ref 'runtrans runkeydat)) - (reason (alist-ref 'message runkeydat)) - (sched (alist-ref 'sched runkeydat)) - (action (alist-ref 'action runkeydat)) - (dbdest (alist-ref 'dbdest runkeydat)) - (append (alist-ref 'append runkeydat)) - (target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced - (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target) - (if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action - ((noaction) #f) - ((run) (and runname reason)) - ((sync) (and reason dbdest)) - (else #f)) - ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt - (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) - (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest) - ))) + (if (area-allowed? area areas) ;; is this area to be handled (from areas=a,b,c ...) + (let ((runname (alist-ref 'runname runkeydat)) + (runtrans (alist-ref 'runtrans runkeydat)) + (reason (alist-ref 'message runkeydat)) + (sched (alist-ref 'sched runkeydat)) + (action (alist-ref 'action runkeydat)) + (dbdest (alist-ref 'dbdest runkeydat)) + (append (alist-ref 'append runkeydat)) + (target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced + (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target) + (if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action + ((noaction) #f) + ((run) (and runname reason)) + ((sync) (and reason dbdest)) + (else #f)) + ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt + (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) + (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest) + )) + (print "NOTE: skipping " runkeydat " for area, not in " areas))) all-areas)) runkeydats))) (let ((res (configf:get-section torun contour))) ;; each contour / target ;; (print "res=" res) res)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -292,10 +292,16 @@ (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) #f))) (if (not test-patts) ;; first time in - adjust testpatt (set! test-patts (common:args-get-testpatt runconf))) + ;; if test-patts is #f at this point there is something wrong and we need to bail out + (if (not test-patts) + (begin + (debug:print 0 *default-log-port* "WARNING: there is no test pattern for this run. Exiting now.") + (exit 0))) + (if (args:get-arg "-tagexpr") (begin (set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ",")) (debug:print-info 0 *default-log-port* "filtering initial test list with tagexpr: " (args:get-arg "-tagexpr") " => " allowed-tests) ));; tests will be ANDed with this list @@ -1703,11 +1709,10 @@ (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) - (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")