| ︙ | | |
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
+
|
Misc
-start-dir path : switch to this directory before running megatest
-rebuild-db : bring the database schema up to date
-cleanup-db : remove any orphan records, vacuum the db
-import-megatest.db : migrate a database from v1.55 series to v1.60 series
-sync-to-megatest.db : migrate data back to megatest.db
-use-db-cache : use cached access to db to reduce load
-update-meta : update the tests metadata for all tests
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
-transport http|rpc : use http or rpc for transport (default is http)
-daemonize : fork into background and disconnect from stdin/out
|
| ︙ | | |
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
285
286
287
288
289
|
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
285
286
287
288
289
290
291
292
293
|
+
+
-
-
+
+
-
+
+
|
"-o"
"-log"
"-archive"
"-since"
"-fields"
"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
"-sort"
"-target-db"
"-source-db"
)
(list "-h" "-help" "--help"
)
(list "-h" "-help" "--help"
"-manual"
"-version"
"-force"
"-xterm"
"-showkeys"
"-show-keys"
"-test-status"
"-set-values"
"-load-test-data"
"-summarize-items"
"-gui"
"-daemonize"
"-preclean"
"-rerun-clean"
"-rerun-all"
"-clean-cache"
"-cache-db"
"-use-db-cache"
;; misc
"-repl"
"-lock"
"-unlock"
"-list-servers"
"-run-wait" ;; wait on a run to complete (i.e. no RUNNING)
"-local" ;; run some commands using local db access
|
| ︙ | | |
479
480
481
482
483
484
485
486
487
488
489
490
491
492
|
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
|
+
+
+
+
+
+
+
+
|
(debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
(on-exit std-exit-procedure)
;;======================================================================
;; Misc general calls
;;======================================================================
(if (and (args:get-arg "-cache-db")
(args:get-arg "-source-db"))
(let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
(target-db (conc temp-dir "/cached.db"))
(source-db (args:get-arg "-source-db")))
(db:cache-for-read-only source-db target-db)
(set! *didsomething* #t)))
;; handle a clean-cache request as early as possible
;;
(if (args:get-arg "-clean-cache")
(begin
(set! *didsomething* #t) ;; suppress the help output.
(if (getenv "MT_TARGET") ;; no point in trying if no target
|
| ︙ | | |
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
|
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
|
-
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
|
dat)))
(string-split fields-spec "+")))
(define (get-value-by-fieldname datavec test-field-index fieldname)
(let ((indx (hash-table-ref/default test-field-index fieldname #f)))
(if indx
(if (>= indx (vector-length datavec))
#f ;; index to high, should raise an error I suppose
#f ;; index too high, should raise an error I suppose
(vector-ref datavec indx))
#f)))
;; Add db direct
;;
(define (dispatch-query access-mode rmt-cmd db-cmd . params)
(if (eq? access-mode 'cached)
(apply db:call-with-cached-db db-cmd params)
(apply rmt-cmd params)))
;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
(if (launch:setup)
(let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
(runpatt (args:get-arg "-list-runs"))
(access-mode (if (args:get-arg "-use-db-cache") 'cached 'rmt))
(testpatt (common:args-get-testpatt #f))
;; (if (args:get-arg "-testpatt")
;; (args:get-arg "-testpatt")
;; "%"))
(keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
;; (runsda t (db:get-runs dbstruct runpatt #f #f '()))
(runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
#f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
(runsdat (dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt keys (or runpatt "%")
(common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
(runstmp (db:get-rows runsdat))
(header (db:get-header runsdat))
;; this is "-since" support. This looks at last mod times of <run-id>.db files
;; and collects those modified since the -since time.
(runs (if (and (not (null? runstmp))
(args:get-arg "-since"))
(let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
|
| ︙ | | |
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
|
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
|
-
+
|
(hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
)))
(let* ((run-id (db:get-value-by-header run header "id"))
(runname (db:get-value-by-header run header "runname"))
(states (string-split (or (args:get-arg "-state") "") ","))
(statuses (string-split (or (args:get-arg "-status") "") ","))
(tests (if tests-spec
(rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
(dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
;; use qryvals if test-spec provided
(if tests-spec
(string-intersperse adj-tests-spec ",")
;; db:test-record-fields
#f)
#f
'normal)
|
| ︙ | | |
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
|
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
|
-
+
|
(conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
"")
;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb*
;; (db:test-get-rundir test) ;; )
)
;; Each test
;; DO NOT remote run
(let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
(let ((steps (dispatch-query access-mode rmt:get-steps-for-test db:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
(for-each
(lambda (step)
(format #t
" Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
(tdb:step-get-stepname step)
(tdb:step-get-state step)
(tdb:step-get-status step)
|
| ︙ | | |