97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
(test "update-test_meta" "test1" (begin
(runs:update-test_meta "test1" tconfig)
(let ((dat (rmt:testmeta-get-record "test1")))
(vector-ref dat 1))))
(define test-path "tests/test1")
(define disk-path #f)
(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*)))
(set! disk-path d)
d))))
(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '()))))
(test #f "" (item-list->path '()))
;;======================================================================
;; Create a test with multiple items and verify that rollup logic works
|
|
|
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
(test "update-test_meta" "test1" (begin
(runs:update-test_meta "test1" tconfig)
(let ((dat (rmt:testmeta-get-record "test1")))
(vector-ref dat 1))))
(define test-path "tests/test1")
(define disk-path #f)
(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat* #f)))
(set! disk-path d)
d))))
(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '()))))
(test #f "" (item-list->path '()))
;;======================================================================
;; Create a test with multiple items and verify that rollup logic works
|
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
(test "launch-test" #t
(string?
(file-exists?
;; (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
(launch-test 30001 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))
(exit 1)
;; (test "Run a test" #t (general-run-call
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
(test "launch-test" #t
(string?
(file-exists?
;; (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
(launch-test 30001 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))
;;======================================================================
;; M O R E R E M O T E C A L L S
;;======================================================================
(test #f '("COMPLETED" "PASS")
(begin
(rmt:set-tests-state-status 1 '("rollup") "COMPLETED" "AUTO" "COMPLETED" "PASS")
(get-state-status 1 "rollup" "")))
(test #f #t (rmt:top-test-set-per-pf-counts 1 "rollup"))
;;======================================================================
;; T E S T I T E M M A P
;;======================================================================
(test #f "a/b/c" (db:multi-pattern-apply "d/e/f" "d a\ne b\nf c"))
(test #f "blah/foo/bar/baz" (db:convert-test-itempath "blah/baz/bar/foo" "^([^/]+)/([^/]+)/([^/]+)$ \\3/\\2/\\1"))
(test #f #t (db:compare-itempaths "abc/def/123" "abc/ghi/123" "ghi def"))
(test #f #f (db:compare-itempaths "some/5" "item/5" ".*/"))
(test #f #t (db:compare-itempaths "some/5" "item/5" ".*/ some/"))
(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(toplevel) itemmap: ".*/" "/"))
(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(normal) itemmap: ".*/" "/"))
(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemmatch) itemmap: ".*/" "/"))
(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemwait) itemmap: ".*/" "/"))
(exit 1)
;; (test "Run a test" #t (general-run-call
|
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
|
(print "Waiting for server to be done, should be about 20 seconds")
(test "server stop" #f (let ((hostname (car *runremote*))
(port (cadr *runremote*)))
(tasks:kill-server #t hostname port server-pid 'http)
(open-run-close tasks:get-best-server tasks:open-db)))
;;======================================================================
;; M O R E R E M O T E C A L L S
;;======================================================================
(test #f #f (rmt:set-tests-state-status 1 '("runfirst") "RUNNING" "WARN" "COMPLETED" "FAIL"))
|
<
<
<
<
<
|
340
341
342
343
344
345
346
347
348
349
350
351
352
353
|
(print "Waiting for server to be done, should be about 20 seconds")
(test "server stop" #f (let ((hostname (car *runremote*))
(port (cadr *runremote*)))
(tasks:kill-server #t hostname port server-pid 'http)
(open-run-close tasks:get-best-server tasks:open-db)))
;; (cdb:kill-server *runremote*)
;; (thread-join! th1 th2 th3)
;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal)
;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())
|