Index: .mtutil.scm
==================================================================
--- .mtutil.scm
+++ .mtutil.scm
@@ -17,23 +17,34 @@
(sorted (sort name-time (lambda (a b)(> (cdr a)(cdr b)))))
(last-name (if (null? sorted)
#f
(caar sorted))))
last-name))))
-
+
;; example of how to set up and write target mappers
;;
-(define *target-mappers*
- `((prefix-contour . ,(lambda (target run-name area area-path reason contour mode-patt)
- (conc contour "/" target)))
- (prefix-area-contour . ,(lambda (target run-name area area-path reason contour mode-patt)
- (conc area "/" contour "/" target)))))
-
-(define *runname-mappers*
- `((corporate-ww . ,(lambda (target run-name area area-path reason contour mode-patt)
- (let* ((last-name (get-last-runname area-path target))
- (last-letter (if (string? last-name)
- (let ((len (string-length last-name)))
- (substring last-name (- len 1) len))
- "a"))
- (next-letter (list->string (list (integer->char (+ (char->integer (string-ref last-letter 0)) 1)))))) ;; surely there is an easier way?
- (conc (seconds->wwdate (current-seconds)) next-letter))))))
+(hash-table-set! *target-mappers*
+ 'prefix-contour
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (conc contour "/" target)))
+(hash-table-set! *target-mappers*
+ 'prefix-area-contour
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (conc area "/" contour "/" target)))
+
+(hash-table-set! *runname-mappers*
+ 'corporate-ww
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (let* ((last-name (get-last-runname area-path target))
+ (last-letter (if (string? last-name)
+ (let ((len (string-length last-name)))
+ (substring last-name (- len 1) len))
+ "a"))
+ (next-letter (list->string
+ (list
+ (integer->char
+ (+ (char->integer (string-ref last-letter 0)) 1)))))) ;; surely there is an easier way?
+ ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
+ (conc (seconds->wwdate (current-seconds)) next-letter))))
+
+(print "Got here!")
+
Index: megatest.config
==================================================================
--- megatest.config
+++ megatest.config
@@ -3,13 +3,14 @@
[areas]
# path-to-area map-target-script(future, optional)
fullrun path=tests/fullrun
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
-ext-tests path=ext-tests; targtrans=prefix-contour
+ext-tests path=ext-tests; targtrans=prefix-contour;
[contours]
# mode-patt/tag-expr
quick selector=QUICKPATT/quick
full areas=fullrun,ext-tests; selector=MAXPATT/all
all areas=fullrun,ext-tests
snazy areas=%; selector=QUICKPATT/
+
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -25,12 +25,12 @@
(include "megatest-fossil-hash.scm")
(require-library stml)
-(define *target-mappers* '())
-(define *runname-mappers* '())
+(define *target-mappers* (make-hash-table)) ;; '())
+(define *runname-mappers* (make-hash-table)) ;; '())
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
@@ -442,30 +442,46 @@
;; generate the pkt keys directly.
;; ii. Pass the pkt keys and values to this proc and go from there.
;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
;;
;; Override the run start time record with sched. Usually #f is fine.
-;;
-(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf)
+;;
+(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans)
(let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
(area-dat (val->alist (or (configf:lookup mtconf "areas" area) "")))
(area-path (alist-ref 'path area-dat))
(area-xlatr (alist-ref 'targtrans area-dat))
- (new-target (if area-xlatr
+ (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
+ (mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
+ (print "callname=" callname " runtrans=" runtrans)
+ (if (and callname
+ (not (equal? callname "auto"))
+ (not mapper))
+ (print "Failed to find runname mapper " callname " for area " area))
+ (if mapper
+ (handle-exceptions
+ exn
+ (begin
+ (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
+ (print " message: " ((condition-property-accessor 'exn 'message) exn))
+ runname)
+ (mapper target runname area area-path reason contour mode-patt))
+ runname)))
+ (new-target (if area-xlatr
(let ((xlatr-key (string->symbol area-xlatr)))
- (if (alist-ref xlatr-key *target-mappers*)
+ (if (hash-table-exists? *target-mappers* xlatr-key)
(begin
(print "Using target mapper: " area-xlatr)
(handle-exceptions
exn
(begin
(print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
- (print " function is: " (alist-ref xlatr-key *target-mappers*))
+ (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runkey)
- ((alist-ref xlatr-key *target-mappers*)
- runkey runname area area-path reason contour mode-patt)))
+ ((hash-table-ref *target-mappers* xlatr-key)
+ runkey new-runname area area-path reason contour mode-patt)))
(begin
(print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")
runkey)))
runkey)))
;; some hacks to remove switches not needed in certain cases
@@ -479,15 +495,15 @@
(if action action "run")
(append
`(("-start-dir" . ,area-path)
("-msg" . ,reason)
("-contour" . ,contour))
- (if (good-val runname) `(("-run-name" . ,runname)) '())
- (if (good-val new-target) `(("-target" . ,new-target)) '())
- (if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '())
- (if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '())
- (if (good-val dbdest) `(("-sync-to" . ,dbdest)) '())
+ (if (good-val new-runname) `(("-run-name" . ,new-runname)) '())
+ (if (good-val new-target) `(("-target" . ,new-target)) '())
+ (if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '())
+ (if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '())
+ (if (good-val dbdest) `(("-sync-to" . ,dbdest)) '())
(if (good-val append-conf) `(("-append-config" . ,append-conf)) '())
(if (not (or mode-patt tag-expr))
`(("-testpatt" . "%"))
'())
)
@@ -528,10 +544,12 @@
(ruletype (if (> len-key 1)(cadr keyparts) #f))
(action (if (> len-key 2)(caddr keyparts) #f))
;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
(val-alist (val->alist val))
(runname (make-runname "" ""))
+ (runtrans (alist-ref 'runtrans val-alist))
+
(runstarts (find-pkts pdb '(runstart) `((o . ,contour)
(t . ,runkey))))
(rspkts (get-pkt-alists runstarts))
;; starttimes is for run start times and is used to know when the last run was launched
(starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
@@ -549,10 +567,12 @@
(let ((delta (lambda (x)
(round (/ (- (current-seconds) x) 60)))))
(print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))
+ (print "val-alist=" val-alist " runtrans=" runtrans)
+
;; look in runstarts for matching runs by target and contour
;; get the timestamp for when that run started and pass it
;; to the rule logic here where "ruletype" will be applied
;; if it comes back "changed" then proceed to register the runs
@@ -582,10 +602,11 @@
((run)
(if (common:extended-cron crontab #f last-run)
(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")
)))))
@@ -622,10 +643,11 @@
(need-run (> last-change last-run)))
(print "last-run: " last-run " need-run: " need-run)
(if need-run
(let* ((key-msg `((message . ,(conc ruletype ":" message))
(runname . ,runname)
+ (runtrans . ,runtrans)
(action . ,action)
(target . ,new-target))))
(print "key-msg: " key-msg)
(push-run-spec torun contour runkey key-msg)))))))
val-alist)) ;; iterate over the param split by ;\s*
@@ -645,15 +667,17 @@
(fossil:last-change-node-and-time fdir fname branch)))
(if (null? starttimes)
(push-run-spec torun contour runkey
`((message . ,(conc "fossil:" branch "-neverrun"))
(runname . ,(conc runname "-" node))
+ (runtrans . ,runtrans)
(target . ,runkey)))
(if (> datetime last-run) ;; change time is greater than last-run time
(push-run-spec torun contour runkey
`((message . ,(conc "fossil:" branch "-" node))
(runname . ,(conc runname "-" node))
+ (runtrans . ,runtrans)
(target . ,runkey)))))
(print "Got datetime=" datetime " node=" node))))
val-alist))
((file file-or) ;; one or more files must be newer than the reference
@@ -663,10 +687,11 @@
;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
(if (null? starttimes) ;; this target has never been run
(push-run-spec torun contour runkey
`((message . "file:neverrun")
(action . ,action)
+ (runtrans . ,runtrans)
(target . ,runkey)
(runname . ,runname)))
;; (for-each
;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour
;; (if (> youngestmod (cdr starttime))
@@ -675,10 +700,11 @@
(if (> youngestmod last-run)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" (cadr youngestdat)))
(action . ,action)
(target . ,runkey)
+ (runtrans . ,runtrans)
(runname . ,runname)
))))))
;; starttimes))
((file-and) ;; all files must be newer than the reference
@@ -689,10 +715,11 @@
;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
(if (null? starttimes) ;; this target has never been run
(push-run-spec torun contour runkey
`((message . "file:neverrun")
(runname . ,runname)
+ (runtrans . ,runtrans)
(target . ,runkey)
(action . ,action)))
;; NB// I think this is wrong. It should be looking at last-run only.
(if (> youngestmod last-run)
@@ -705,10 +732,11 @@
;; (begin
;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" (cadr youngestdat)))
(runname . ,runname)
+ (runtrans . ,runtrans)
(target . ,runkey)
(action . ,action)
))))))
(else (print "ERROR: unrecognised rule \"" ruletype)))))
keydats))) ;; sense rules
@@ -733,10 +761,11 @@
(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))
@@ -746,11 +775,11 @@
((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)
+ (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)
)))
all-areas))
runkeydats)))
(let ((res (configf:get-section torun contour))) ;; each contour / target
Index: runconfigs.config
==================================================================
--- runconfigs.config
+++ runconfigs.config
@@ -7,32 +7,32 @@
#
# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
-all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
-quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
+# all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
+# quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
# tip will be replaced with hashkey?
[v1.63/tip/dev]
# file: files changes since last run trigger new run
# script: script is called with unix seconds as last parameter (other parameters are preserved)
#
# contour:sensetype:action params data
-quick:file:run run-name=auto;glob=/home/matt/data/megatest/*.scm
-snazy:file:run run-name=auto;glob=/home/matt/data/megatest/*.scm
+quick:file:run runtrans=auto;glob=/home/matt/data/megatest/*.scm
+snazy:file:run runtrans=corporate-ww;glob=/home/matt/data/megatest/*.scm
# script returns change-time (unix epoch), new-target-name, run-name
#
# quick:script:run checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\
# checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk
# fossil based trigger
#
-quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.63;\
- http://www.kiatoa.com/fossils/megatest_qa=trunk;\
- http://www.kiatoa.com/fossils/megatest=v1.64
+#quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.63;\
+# http://www.kiatoa.com/fossils/megatest_qa=trunk;\
+# http://www.kiatoa.com/fossils/megatest=v1.64
# field allowed values
# ----- --------------
# minute 0-59
# hour 0-23