440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
|
;; 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)
(let* ((area-dat (val->alist (or (configf:lookup mtconf "areas" area) "")))
|
>
|
|
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
|
;; 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)
(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
(let ((xlatr-key (string->symbol area-xlatr)))
(if (alist-ref xlatr-key *target-mappers*)
(begin
(print "Using target mapper: " area-xlatr)
|
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
|
(let-values (((uuid pkt)
(command-line->pkt
(if action action "run")
(append
`(("-start-dir" . ,area-path)
("-msg" . ,reason)
("-contour" . ,contour))
(if runname `(("-run-name" . ,runname)) '())
(if new-target `(("-target" . ,new-target)) '())
(if mode-patt `(("-mode-patt" . ,mode-patt)) '())
(if tag-expr `(("-tag-expr" . ,tag-expr)) '())
(if dbdest `(("-sync-to" . ,dbdest)) '())
(if append-conf `(("-append-config" . ,append-conf)) '())
(if (not (or mode-patt tag-expr))
`(("-testpatt" . "%"))
'())
)
sched)))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
|
|
|
|
|
|
|
|
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
|
(let-values (((uuid pkt)
(command-line->pkt
(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 append-conf) `(("-append-config" . ,append-conf)) '())
(if (not (or mode-patt tag-expr))
`(("-testpatt" . "%"))
'())
)
sched)))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
|
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
|
(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) "") ","))
(selector (alist-ref 'selector val-alist))
(mode-tag (and selector (string-split selector "/")))
(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
(lambda (runkeydatset)
;; (print "runkeydatset: ")(pp runkeydatset)
(let ((runkey (car runkeydatset))
(runkeydats (cadr runkeydatset)))
|
|
|
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
|
(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) "") ","))
(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
(lambda (runkeydatset)
;; (print "runkeydatset: ")(pp runkeydatset)
(let ((runkey (car runkeydatset))
(runkeydats (cadr runkeydatset)))
|