︙ | | | ︙ | |
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
'(
("-area" . G) ;; maps to group
("-contour" . c)
("-append-config" . d)
("-state" . e)
("-item-patt" . i)
("-sync-to" . k)
("-run-name" . n)
("-mode-patt" . o)
("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
("-status" . s)
("-target" . t)
("-tag-expr" . x)
;; misc
|
>
|
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
'(
("-area" . G) ;; maps to group
("-contour" . c)
("-append-config" . d)
("-state" . e)
("-item-patt" . i)
("-sync-to" . k)
("-new" . l) ;; l (see below) is new-ss
("-run-name" . n)
("-mode-patt" . o)
("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
("-status" . s)
("-target" . t)
("-tag-expr" . x)
;; misc
|
︙ | | | ︙ | |
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
(D . timestamp )
(T . cardtype )
(U . user ) ;; username
(Z . shar1sum )
;; Extras
(a . runkey ) ;; needed for matching up pkts with target derived from runkey
))
;; inlst is an alternative input
;;
(define (lookup-param-by-key key #!key (inlst #f))
(fold (lambda (a res)
(if (eq? (cdr a) key)
|
>
|
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
(D . timestamp )
(T . cardtype )
(U . user ) ;; username
(Z . shar1sum )
;; Extras
(a . runkey ) ;; needed for matching up pkts with target derived from runkey
;; (l . new-ss ) ;; new state/status
))
;; inlst is an alternative input
;;
(define (lookup-param-by-key key #!key (inlst #f))
(fold (lambda (a res)
(if (eq? (cdr a) key)
|
︙ | | | ︙ | |
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
;;
(define (param-translate param)
(or (alist-ref (string->symbol param)
'((-tag-expr . "-tagexpr")
(-mode-patt . "--modepatt")
(-run-name . "-runname")
(-test-patt . "-testpatt")
(-msg . "-m")))
param))
(define (val->alist val)
(let ((val-list (string-split-fields ";\\s*" val #:infix)))
(if val-list
(map (lambda (x)
(let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
|
|
>
|
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
|
;;
(define (param-translate param)
(or (alist-ref (string->symbol param)
'((-tag-expr . "-tagexpr")
(-mode-patt . "--modepatt")
(-run-name . "-runname")
(-test-patt . "-testpatt")
(-msg . "-m")
(-new . "-set-state-status")))
param))
(define (val->alist val)
(let ((val-list (string-split-fields ";\\s*" val #:infix)))
(if val-list
(map (lambda (x)
(let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
|
︙ | | | ︙ | |
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
|
;; collect, translate, collate and assemble a pkt from the command-line
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;; extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f))
(let* ((sched (cond
((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
((number? sched-in) sched-in)
(else (current-seconds))))
(args-data (if args-alist
(if (hash-table? args-alist) ;; seriously?
(hash-table->alist args-alist)
|
|
|
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
;; collect, translate, collate and assemble a pkt from the command-line
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;; extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f))
(let* ((sched (cond
((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
((number? sched-in) sched-in)
(else (current-seconds))))
(args-data (if args-alist
(if (hash-table? args-alist) ;; seriously?
(hash-table->alist args-alist)
|
︙ | | | ︙ | |
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
|
(areas (val-alist->areas cval-alist))
(selector (alist-ref 'selector cval-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)))))
(print "contour: " contour " areas=" areas " cval=" cval)
(for-each
(lambda (runkeydatset)
;; (print "runkeydatset: ")(pp runkeydatset)
(let ((runkey (car runkeydatset))
(runkeydats (cadr runkeydatset)))
(for-each
(lambda (runkeydat)
(for-each
(lambda (area)
|
|
|
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
|
(areas (val-alist->areas cval-alist))
(selector (alist-ref 'selector cval-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)))))
(print "contour: " contour " areas=" areas " cval=" cval)
(for-each
(lambda (runkeydatset)
;; (print "runkeydatset: ")(pp runkeydatset)
(let ((runkey (car runkeydatset))
(runkeydats (cadr runkeydatset)))
(for-each
(lambda (runkeydat)
(for-each
(lambda (area)
|
︙ | | | ︙ | |
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
|
(mtconf (car mtconfdat))
(area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
(areasec (if area (configf:lookup mtconf "areas" area) #f))
(areadat (if areasec (val->alist areasec) #f))
(area-path (if areadat (alist-ref 'path areadat) #f))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(adjargs (hash-table-copy args:arg-hash)))
;; check a few things
(if (and area
(not area-path))
(begin
(print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
(exit 1)))
;; (for-each
;; (lambda (key)
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs #f area-path: area-path)))
(write-pkt pktsdir uuid pkt))))
((dispatch import rungen process)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(toppath (configf:lookup mtconf "scratchdat" "toppath")))
(case (string->symbol *action*)
((process) (begin
|
|
>
|
|
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
|
(mtconf (car mtconfdat))
(area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
(areasec (if area (configf:lookup mtconf "areas" area) #f))
(areadat (if areasec (val->alist areasec) #f))
(area-path (if areadat (alist-ref 'path areadat) #f))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(adjargs (hash-table-copy args:arg-hash))
(new-ss (args:get-arg "-new")))
;; check a few things
(if (and area
(not area-path))
(begin
(print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
(exit 1)))
;; (for-each
;; (lambda (key)
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
(write-pkt pktsdir uuid pkt))))
((dispatch import rungen process)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(toppath (configf:lookup mtconf "scratchdat" "toppath")))
(case (string->symbol *action*)
((process) (begin
|
︙ | | | ︙ | |