| ︙ | | |
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
|
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
290
291
|
+
+
-
-
+
+
-
+
|
"-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"
;; 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
|
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
|
+
+
+
+
+
+
+
+
|
(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
|
| ︙ | | |
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
|
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
|
-
-
-
+
+
+
+
+
|
(let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
(runpatt (args:get-arg "-list-runs"))
(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 (db:call-with-cached-db db: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))
(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
|
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
|
-
+
|
(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
(db:call-with-cached-db 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
|
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
|
-
+
|
(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 (db:call-with-cached-db 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)
|
| ︙ | | |