| ︙ | | |
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
|
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
|
-
+
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-18 extras format pkts pkts regex regex-case
srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)) ;; zmq extras)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
|
| ︙ | | |
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
|
(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
Usage: mtutil action [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
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
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
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
areas, contours, setup : show areas, contours or setup section from megatest.config
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
-target key1/key2/... : run for key1, key2, etc.
-test-patt p1/p2,p3/... : % is wildcard
-run-name : required, name for this particular test run
-contour contourname : run all targets for contourname, requires -run-name, -target
-state-status c/p,c/f : Specify a list of state and status patterns
-tag-expr tag1,tag2%,.. : select tests with tags matching expression
-mode-patt key : load testpatt from <key> in runconfigs instead of default TESTPATT
if -testpatt and -tagexpr are not specified
-new state/status : specify new state/status for set-ss
Misc
-start-dir path : switch to this directory before running mtutil
-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\"
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
-target key1/key2/... : run for key1, key2, etc.
-test-patt p1/p2,p3/... : % is wildcard
-run-name : required, name for this particular test run
-contour contourname : run all targets for contourname, requires -run-name, -target
-state-status c/p,c/f : Specify a list of state and status patterns
-tag-expr tag1,tag2%,.. : select tests with tags matching expression
-mode-patt key : load testpatt from <key> in runconfigs instead of default TESTPATT
if -testpatt and -tagexpr are not specified
-new state/status : specify new state/status for set-ss
Misc
-start-dir path : switch to this directory before running mtutil
-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
mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
# Start a contour
mtutil run -contour quick -target v1.63/aa3e
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
;; args and pkt key specs
;;
(define *arg-keys*
'(
'(("-area" . G) ;; maps to group
("-target" . t)
("-run-name" . n)
("-state" . e)
("-status" . s)
("-contour" . c)
("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
("-mode-patt" . o)
("-tag-expr" . x)
("-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)
("-item-patt" . i)
("-sync-to" . k)
("-append-config" . d)
("-start-dir" . S)
("-msg" . M)
("-set-vars" . v)
("-debug" . #f) ;; for *verbosity* > 2
("-load" . #f) ;; load and exectute a scheme file
("-log" . #f)
'(("-h" . #f)
("-help" . #f)
("--help" . #f)
("-manual" . #f)
("-version" . #f)
;; misc
("-repl" . #f)
("-immediate" . I)
("-preclean" . r)
("-rerun-all" . u)
("-h" . #f)
("-help" . #f)
("--help" . #f)
("-manual" . #f)
("-version" . #f)
;; misc
("-repl" . #f)
("-immediate" . I)
("-preclean" . r)
("-rerun-all" . u)
("-prepend-contour" . w)
))
;; alist to map actions to old megatest commands
(define *action-keys*
'((run . "-run")
(sync . "")
(archive . "-archive")
|
| ︙ | | |
296
297
298
299
300
301
302
303
304
305
306
307
308
309
|
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
|
+
|
;;
(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.
(equal? *action* "show") ;; just keep going if list
)))
(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)
|
| ︙ | | |
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
|
324
325
326
327
328
329
330
331
332
333
334
335
336
337
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
|
-
-
-
+
+
+
+
+
-
-
+
+
+
|
(toppath (configf:lookup mtconf "dyndat" "toppath"))
(pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir)))
(if (not (and pktsdir toppath pdbpath))
(begin
(print "ERROR: settings are missing in your megatest.config for area management.")
(print " you need to have pktsdir in the [setup] section."))
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(proc pktsdirs pktsdir pdb)
(dbi:close pdb)))))
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))
(res (proc pktsdirs pktsdir pdb)))
(dbi:close pdb)
res
))))
(define (load-pkts-to-db mtconf)
(with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(if (and (file-exists? pktsdir)
(directory? pktsdir)
(file-read-access? pktsdir))
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(ptype (alist-ref 'T apkt))
(parent (alist-ref 'P apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) parent 0)
(debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
(debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
pkts))))
(string-split pktsdirs)))))
(define (get-pkt-alists pkts)
|
| ︙ | | |
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
492
493
494
495
496
497
498
499
500
501
502
503
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
|
-
+
+
+
+
+
+
-
+
-
+
+
|
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runkey)
((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)))
runkey))
(actual-action (if action
(if (equal? action "sync-prepend")
"sync"
action)
"run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
;; some hacks to remove switches not needed in certain cases
(case (string->symbol (or action "run"))
((sync)
((sync sync-prepend)
(set! new-target #f)
(set! runame #f)))
(print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target)
(let-values (((uuid pkt)
(command-line->pkt
(if action action "run")
actual-action
(append
`(("-start-dir" . ,area-path)
("-msg" . ,reason)
("-contour" . ,contour))
(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 (equal? action "sync-prepend") '(("-prepend-contour" . " ")) '())
(if (not (or mode-patt tag-expr))
`(("-testpatt" . "%"))
'())
(if (or (not action)
(equal? action "run"))
`(("-preclean" . " ")
("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder
|
| ︙ | | |
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
|
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
|
-
+
|
(areas (val-alist->areas val-alist))
;; (action (alist-ref 'action val-alist))
(cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X"))
(runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
;; (print "last-run: " last-run " need-run: " need-run)
;; (if need-run
(case (string->symbol action)
((sync)
((sync sync-prepend)
(if (common:extended-cron crontab #f last-sync)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":sync-" cron-safe-string))
(action . ,action)
(dbdest . ,(alist-ref 'dbdest val-alist))
(append . ,(alist-ref 'appendconf val-alist))))))
((run)
|
| ︙ | | |
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
|
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
|
-
+
|
(dbdest (alist-ref 'dbdest runkeydat))
(append (alist-ref 'append runkeydat))
(target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced
(print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target)
(if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action
((noaction) #f)
((run) (and runname reason))
((sync) (and reason dbdest))
|
| ︙ | | |
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
|
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
|
-
+
|
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(if *action*
(case (string->symbol *action*)
((run remove rerun set-ss archive kill)
((run remove rerun set-ss archive kill list)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(adjargs (hash-table-copy args:arg-hash)))
;; (for-each
;; (lambda (key)
|
| ︙ | | |
935
936
937
938
939
940
941
942
943
944
945
946
947
948
|
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(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)))))
;; misc
((show)
(if (> (length remargs) 0)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(sect-dat (configf:get-section mtconf (car remargs))))
(if sect-dat
(for-each
(lambda (entry)
(if (> (length entry) 1)
(print (car entry) " " (cadr entry))
(print (car entry))))
sect-dat)
(print "No section \"" (car remargs) "\" found")))
(print "ERROR: list requires section parameter; areas, setup or contours")))
((gendot)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat)))
(with-queue-db
mtconf
(lambda (pktsdirs pktsdir conn)
(make-report "out.dot" conn '())))))
((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))
|
| ︙ | | |
975
976
977
978
979
980
981
|
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
|
+
+
+
+
+
+
|
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "mtutil> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))))
#|
(define mtconf (car (simple-setup #f)))
(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#
|