17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
>
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
|
((print-run)
(debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
((run-wait)
(debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
(else
(debug:print-info 0 "action not recognised " action)))
(let ((sorted-tests (sort tests (lambda (a b)(let ((dira (sdb:qry 'getstr (db:test-get-rundir a)))
(dirb (sdb:qry 'getstr (db:test-get-rundir b))))
(if (and (string? dira)(string? dirb))
(> (string-length dira)(string-length dirb))
#f)))))
(test-retry-time (make-hash-table))
(allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em
(let loop ((test (car sorted-tests))
(tal (cdr sorted-tests)))
(let* ((test-id (db:test-get-id test))
(new-test-dat (cdb:get-test-info-by-id *runremote* test-id)))
(if (not new-test-dat)
(begin
(debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
(if (not (null? tal))
(loop (car tal)(cdr tal))))
(let* ((item-path (db:test-get-item-path new-test-dat))
(test-name (db:test-get-testname new-test-dat))
(run-dir (sdb:qry 'getstr (db:test-get-rundir new-test-dat))) ;; run dir is from the link tree
(real-dir (if (file-exists? run-dir)
(resolve-pathname run-dir)
#f))
(test-state (db:test-get-state new-test-dat))
(test-fulln (db:test-get-fullname new-test-dat)))
(case action
((remove-runs)
|
|
|
|
|
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
|
((print-run)
(debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
((run-wait)
(debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
(else
(debug:print-info 0 "action not recognised " action)))
(let ((sorted-tests (sort tests (lambda (a b)(let ((dira (filedb:get-path *fdb* (db:test-get-rundir a)))
(dirb (filedb:get-path *fdb* (db:test-get-rundir b))))
(if (and (string? dira)(string? dirb))
(> (string-length dira)(string-length dirb))
#f)))))
(test-retry-time (make-hash-table))
(allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em
(let loop ((test (car sorted-tests))
(tal (cdr sorted-tests)))
(let* ((test-id (db:test-get-id test))
(new-test-dat (cdb:get-test-info-by-id *runremote* test-id)))
(if (not new-test-dat)
(begin
(debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
(if (not (null? tal))
(loop (car tal)(cdr tal))))
(let* ((item-path (db:test-get-item-path new-test-dat))
(test-name (db:test-get-testname new-test-dat))
(run-dir (filedb:get-path *fdb* (db:test-get-rundir new-test-dat))) ;; run dir is from the link tree
(real-dir (if (file-exists? run-dir)
(resolve-pathname run-dir)
#f))
(test-state (db:test-get-state new-test-dat))
(test-fulln (db:test-get-fullname new-test-dat)))
(case action
((remove-runs)
|