Merged partial working control of areas to affect from trigger config line. If using --modepatt (or -mode-patt) DO NOT run anything if the PATT is not found in runconfigs

Author: matt

common.scm

@@ -971,6 +971,10 @@
          (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)

mtut.scm

@@ -522,6 +522,15 @@ Version " megatest-version ", built from " megatest-fossil-hash ))
 	(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
@@ -596,6 +605,7 @@ Version " megatest-version ", built from " megatest-fossil-hash ))
 			  (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")))))
@@ -617,6 +627,13 @@ Version " megatest-version ", built from " megatest-fossil-hash ))
 						    (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")
 			       )))))
@@ -696,6 +713,7 @@ Version " megatest-version ", built from " megatest-fossil-hash ))
 
 		     ((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)
@@ -762,7 +780,7 @@ Version " megatest-version ", built from " megatest-fossil-hash ))
 	    (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)))
@@ -776,24 +794,26 @@ Version " megatest-version ", built from " megatest-fossil-hash ))
 		    (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

runs.scm

@@ -294,6 +294,12 @@
 
     (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")) ","))
@@ -1705,7 +1711,6 @@
                  (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))