65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
(vector header res)))
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
;; Awful. Please FIXME
(define *env-vars-by-run-id* (make-hash-table))
(define *current-run-name* #f)
(define (db:get-run-key-val db run-id key)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
(conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
|
<
<
<
<
|
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
(vector header res)))
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
(define (db:get-run-key-val db run-id key)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
(conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
|
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
;; keyvals.
;;
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-names test-patts user flags)
(let* ((db #f)
(keys (cdb:remote-run db:get-keys #f))
(keyvallst (keys:target->keyval keys target))
(run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
|
>
|
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
;; keyvals.
;;
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-names test-patts user flags)
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (cdb:remote-run db:get-keys #f))
(keyvallst (keys:target->keyval keys target))
(run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
|
726
727
728
729
730
731
732
733
734
735
736
737
738
739
|
;; action:
;; 'remove-runs
;; 'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f))
(let* ((db #f)
(keys (open-run-close db:get-keys db))
(rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
|
>
|
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
|
;; action:
;; 'remove-runs
;; 'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (open-run-close db:get-keys db))
(rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
|