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
|
Actions include:
run : initial 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
process : master area only, process pkts, manage run jobs
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
-state-status c/p,c/f : Specify a list of state and status patterns
-mode-patt key : load testpatt from <key> in runconfigs instead of default TESTPATT
if -testpatt and -tagexpr are not specified
-tag-expr tag1,tag2%,.. : select tests with tags matching expression
-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
|
|
>
>
>
>
<
|
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
|
Actions include:
run : initial 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
import : master area only, import pkts
process : process imported pkts, manage run jobs
rungen : look at input sense list in [rungen] and generate run pkts
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
|
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
|
(define *arg-keys*
'(("-run" . r)
("-area" . G) ;; maps to group
("-target" . t)
("-run-name" . n)
("-state" . e)
("-status" . s)
("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
("-mode-patt" . o)
("-tag-expr" . x)
("-item-patt" . i)
;; misc
("-start-dir" . #f)
("-set-vars" . v)
("-debug" . #f) ;; for *verbosity* > 2
("-load" . #f) ;; load and exectute a scheme file
("-log" . #f)
))
(define *switch-keys*
'(("-h" . #f)
("-help" . #f)
("--help" . #f)
("-manual" . #f)
("-version" . #f)
;; misc
("-repl" . #f)
("-immediate" . I)
("-process" . #f) ;; read any new actions, process actions as needed, archive action pkts when appropriate
))
;; a action
;; u username (Unix)
;; D timestamp
;; process args
|
>
<
|
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
|
(define *arg-keys*
'(("-run" . r)
("-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)
("-item-patt" . i)
;; misc
("-start-dir" . #f)
("-set-vars" . v)
("-debug" . #f) ;; for *verbosity* > 2
("-load" . #f) ;; load and exectute a scheme file
("-log" . #f)
))
(define *switch-keys*
'(("-h" . #f)
("-help" . #f)
("--help" . #f)
("-manual" . #f)
("-version" . #f)
;; misc
("-repl" . #f)
("-immediate" . I)
))
;; a action
;; u username (Unix)
;; D timestamp
;; process args
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;;======================================================================
;; Process pkts
;;======================================================================
(define (load-pkts-to-db mtconf)
(let* ((pktsdir (configf:lookup mtconf "setup" "pktsdir"))
(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));")))
(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")))
(add-to-queue pdb pktdat uuid 'cmd #f 0)
(print "Added " uuid " to queue"))
(print "pkt: " uuid " exists, skipping...")
)))
pkts)
(dbi:close pdb)))))
;;======================================================================
;; Runs
;;======================================================================
;; collect, translate, collate and assemble a pkt from the command-line
|
|
>
|
|
|
|
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;;======================================================================
;; Process pkts
;;======================================================================
(define (load-pkts-to-db mtconf)
(let* ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(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));"))))
(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")))
(add-to-queue pdb pktdat uuid 'cmd #f 0)
(print "Added " uuid " to queue"))
(print "pkt: " uuid " exists, skipping...")
)))
pkts))))
(string-split pktsdirs))
(dbi:close pdb)))))
;;======================================================================
;; Runs
;;======================================================================
;; collect, translate, collate and assemble a pkt from the command-line
|
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
mtconfdat))
(if *action*
(case (string->symbol *action*)
((run remove rerun set-ss archive kill)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(pktsdir (configf:lookup mtconf "setup" "pktsdir"))
(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 #f adjargs)))
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
(print "ERROR: cannot process commands without a pkts directory")))))
((process)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat)))
(load-pkts-to-db mtconf)))))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
(import extras) ;; might not be needed
;; (import csi)
(import readline)
|
|
>
|
>
|
|
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
|
mtconfdat))
(if *action*
(case (string->symbol *action*)
((run remove rerun set-ss archive kill)
(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)
;; (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 #f adjargs)))
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
(print "ERROR: cannot process commands without a pkts directory")))))
((process import rungen)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat)))
(case (string->symbol *action*)
((import)(load-pkts-to-db mtconf)))))))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
(import extras) ;; might not be needed
;; (import csi)
(import readline)
|