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