71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
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
|
-
+
-
-
+
+
+
+
+
+
|
(lambda (a . r)
(set! res (cons (list->vector (cons a r)) res)))
db
(conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";")
runnamepatt)
(vector header res)))
(define (register-test db run-id test-name item-path)
(define (register-test db run-id test-name item-path tags)
(let ((item-paths (if (equal? item-path "")
(list item-path)
(list item-path ""))))
(for-each
(lambda (pth)
(sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" run-id test-name pth))
item-paths)))
(sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status,tags) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a',?);"
run-id
test-name
pth
(conc "," (string-intersperse tags ",") ",")))
item-paths )))
;; (define db (open-db))
;; (test-set-status! db 2 "runfirst" "COMPLETED" "PASS" "summer")
(define (test-set-status! db run-id test-name state status itemdat-or-path . comment)
(let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))))
(sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
|
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
|
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
|
-
+
+
+
|
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
(let* ((test-path (conc *toppath* "/tests/" test-name))
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
(test-conf (if testexists (read-config test-configf) (make-hash-table)))
(waiton (let ((w (config-lookup test-conf "requirements" "waiton")))
(if (string? w)(string-split w)'()))))
(if (string? w)(string-split w)'())))
(tags (let ((t (config-lookup test-conf "setup" "tags")))
(if (string? t)(string-split t ",") '()))))
(if (not testexists)
(begin
(debug:print 0 "ERROR: Can't find config file " test-configf)
(exit 2))
;; put top vars into convenient variables and open the db
(let* (;; db is always at *toppath*/db/megatest.db
(items (hash-table-ref/default test-conf "items" '()))
|
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
-
+
|
(if (runs:can-run-more-tests db)
(begin
(let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
(ct 0))
(if (and (not ts)
(< ct 10))
(begin
(register-test db run-id test-name item-path)
(register-test db run-id test-name item-path tags)
(db:test-set-comment db run-id test-name item-path "")
(loop2 (db:get-test-info db run-id test-name item-path)
(+ ct 1)))
(if ts
(set! testdat ts)
(begin
(debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
|