64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
limit))
(vector header full-list)))))
;;======================================================================
;; T E S T S
;;======================================================================
(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f))
(let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals))
(res '())
(offset 0)
(limit 500))
(let* ((full-list (append res testsdat))
(have-more (eq? (length testsdat) limit)))
(if have-more
(let ((new-offset (+ offset limit)))
(debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
(loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals)
full-list
new-offset
limit))
full-list))))
(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) )
(let* ((key (list run-id waitons ref-item-path mode))
|
|
|
|
|
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
limit))
(vector header full-list)))))
;;======================================================================
;; T E S T S
;;======================================================================
(define (mt:get-tests-for-run run-id testpatt states status area-dat #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f))
(let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals area-dat))
(res '())
(offset 0)
(limit 500))
(let* ((full-list (append res testsdat))
(have-more (eq? (length testsdat) limit)))
(if have-more
(let ((new-offset (+ offset limit)))
(debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
(loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals area-dat)
full-list
new-offset
limit))
full-list))))
(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) )
(let* ((key (list run-id waitons ref-item-path mode))
|
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
(mt:process-triggers run-id test-id newstate newstatus)
#t)))
(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
(let ((test-id (rmt:get-test-id run-id test-name item-path)))
(mt:test-set-state-status-by-id test-id new-state new-status new-comment)))
(define (mt:lazy-read-test-config test-name)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
(if tconf
tconf
(let ((test-dirs (tests:get-tests-search-path *configdat*)))
(let loop ((hed (car test-dirs))
(tal (cdr test-dirs)))
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (file-exists? tconfig-file)
(file-read-access? tconfig-file))
(let ((link-tree-path (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print 0 "ERROR: No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
|
|
|
>
|
|
|
|
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
(mt:process-triggers run-id test-id newstate newstatus)
#t)))
(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
(let ((test-id (rmt:get-test-id run-id test-name item-path)))
(mt:test-set-state-status-by-id test-id new-state new-status new-comment)))
(define (mt:lazy-read-test-config test-name area-dat)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f))
(configdat (megatest:area-configdat area-dat)))
(if tconf
tconf
(let ((test-dirs (tests:get-tests-search-path configdat area-dat)))
(let loop ((hed (car test-dirs))
(tal (cdr test-dirs)))
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (file-exists? tconfig-file)
(file-read-access? tconfig-file))
(let ((link-tree-path (configf:lookup configdat "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print-info 0 "No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
|