17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
+
|
srfi-18 extras format pkts regex
(prefix dbi dbi:)) ;; zmq extras)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(include "megatest-fossil-hash.scm")
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
|
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
+
|
Actions:
run : initiate runs
remove : remove runs
rerun : register action for processing
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
Contour actions:
process : runs import, rungen and dispatch
Selectors
-immediate : apply this action immediately, default is to queue up actions
-area areapatt1,area2... : apply this action only to the specified areas
|
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
+
+
+
|
-set-vars V1=1,V2=2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-log logfile : send stdout and stderr to logfile
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
-debug N|N,M,O... : enable debug messages 0-N or N and M and O ...
Utility
db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"
Examples:
# Start a megatest run in the area \"mytests\"
mtutil -area mytests -action run -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
# Start a contour
mtutil run -contour quick -target v1.63/aa3e
|
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
+
|
;; Add args that use remargs here
;;
(if (and (not (null? remargs))
(not (or
(args:get-arg "-runstep")
(args:get-arg "-envcap")
(args:get-arg "-envdelta")
(member *action* '("db")) ;; very loose checks on db.
)))
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
(if (or (args:any? "-h" "help" "-help" "--help")
(member *action* '("-h" "-help" "--help" "help")))
(begin
(print help)
|
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
|
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
|
-
+
|
;; pathenvvar: "MT_RUN_AREA_HOME"
))
(mtconf (if mtconfdat (car mtconfdat) #f)))
;; we set some dynamic data in a section called "dyndata"
(if mtconf
(begin
(configf:section-var-set! mtconf "dyndat" "toppath" start-dir)))
(print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
;; (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
mtconfdat))
;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.
;; make a run request pkt from basic data
|
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
|
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
|
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
-
-
-
-
+
+
+
+
+
-
+
+
-
-
+
+
-
+
|
(let* ((keydats (configf:get-section rgconf runkey)))
(for-each
(lambda (sense) ;; these are the sense rules
(let* ((key (car sense))
(val (cadr sense))
(keyparts (string-split key ":"))
(contour (car keyparts))
(len-key (length keyparts))
(ruletype (let ((res (cdr keyparts)))
(if (null? res) #f (cadr keyparts))))
(valparts (string-split val)) ;; runname-rule params
(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 (if val-list
(map (lambda (x)
(let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
(case (length f)
((0) `(,#f)) ;; null string case
((1) `(,(string->symbol (car f))))
((2) `(,(string->symbol (car f)) . ,(cadr f)))
(else f))))
val-list)
'()))
(runname (make-runname "" ""))
(runstarts (find-pkts pdb '(runstart) `((o . ,contour)
(t . ,runkey))))
(rspkts (map (lambda (x)
(alist-ref 'pkta x))
runstarts))
(starttimes ;; sort by age (youngest first) and delete duplicates by target
(delete-duplicates
(sort
(map (lambda (x)
`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
rspkts)
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
)
;; 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
(case (string->symbol ruletype)
(case (string->symbol (or ruletype "no-such-rule"))
((no-such-rule) (print "ERROR: no such rule for " sense))
((scheduled)
(if (not (eq? (length valparts) 6))
(print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\"")
(let* ((run-name (car valparts))
(crontab (string-intersperse (cdr valparts)))
(if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
(print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
(let* ((run-name (alist-ref 'run-name val-alist))
(crontab (alist-ref 'cron val-alist))
(action (alist-ref 'action val-alist))
(last-run (if (null? starttimes) ;; never run
0
(apply max (map cdr starttimes))))
(need-run (common:cron-event crontab #f last-run))
(runname (if need-run (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
(print "last-run: " last-run " need-run: " need-run)
(if need-run
(configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (string-intersperse (cdr valparts) "-")) ,runname ,need-run))))))
(configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (string-intersperse (string-split (alist-ref 'cron val-alist)) "-"))
,runname ,need-run ,action))))))
((file file-or) ;; one or more files must be newer than the reference
(let* ((file-globs (cdr valparts))
(youngestdat (common:get-youngest file-globs))
(let* ((file-globs (alist-ref 'glob val-alist))
(youngestdat (common:get-youngest (common:bash-glob file-globs)))
(youngestmod (car youngestdat)))
;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
(if (null? starttimes) ;; this target has never been run
(configf:section-var-set! torun contour runkey `("file:neverrun" ,runname))
(for-each
(lambda (starttime) ;; look at the time the last run was kicked off for this contour
(if (> youngestmod (cdr starttime))
(begin
(print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
(configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname #f)))))
starttimes))
))
((file-and) ;; all files must be newer than the reference
(let* ((file-globs (cdr valparts))
(let* ((file-globs (alist-ref 'glob val-alist))
(youngestdat (common:get-youngest file-globs))
(youngestmod (car youngestdat))
(success #t)) ;; any cases of not true, set flag to #f for AND
;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
(if (null? starttimes) ;; this target has never been run
(configf:section-var-set! torun contour runkey `("file:neverrun" ,runname #f))
(for-each
|
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
|
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
|
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(adjargs (hash-table-copy args:arg-hash)))
;; (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)))
(command-line->pkt *action* adjargs #f)))
(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 "dyndat" "toppath")))
(case (string->symbol *action*)
((process) (begin
(load-pkts-to-db mtconf)
(generate-run-pkts mtconf toppath)
(load-pkts-to-db mtconf)
(dispatch-commands mtconf toppath)))
((import) (load-pkts-to-db mtconf)) ;; import pkts
((rungen) (generate-run-pkts mtconf toppath))
((dispatch) (dispatch-commands mtconf toppath)))))))
((dispatch) (dispatch-commands mtconf toppath)))))
((db)
(if (null? remargs)
(print "ERROR: missing sub command for db command")
(let ((subcmd (car remargs)))
(case (string->symbol subcmd)
((pgschema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-pg.sql")))
(if (file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((junk)
(rmt:get-keys))))))))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
(import extras) ;; might not be needed
;; (import csi)
(import readline)
|