46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
;;
(define (runs:get-runs-by-patt db keys runnamepatt) ;; test-name)
(let* ((keyvallst (keys->vallist keys))
(tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt ""))
(for-each (lambda (keyval)
|
|
|
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
;;
(define (runs:get-runs-by-patt db keys runnamepatt . params) ;; test-name)
(let* ((keyvallst (keys->vallist keys))
(tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt ""))
(for-each (lambda (keyval)
|
273
274
275
276
277
278
279
280
281
282
283
284
285
286
|
(begin
(let loop2 ((ts #f)
(ct 0))
(if (and (not ts)
(< ct 10))
(begin
(register-test db run-id test-name item-path)
(db:delete-test-step-records db run-id test-name) ;; clean out if this is a re-run
(loop2 (db:get-test-info db run-id test-name item-path)
(+ ct 1)))
(if ts
(set! test-status ts)
(begin
(print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
|
>
>
>
|
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
(begin
(let loop2 ((ts #f)
(ct 0))
(if (and (not ts)
(< ct 10))
(begin
(register-test db run-id test-name item-path)
(db:test-set-comment db run-id test-name item-path "")
;; (test-set-status! db run-id test-name "NOT_STARTED" "n/a" itemdat "")
;; (db:set-comment-for-test db run-id test-name item-path "")
(db:delete-test-step-records db run-id test-name) ;; clean out if this is a re-run
(loop2 (db:get-test-info db run-id test-name item-path)
(+ ct 1)))
(if ts
(set! test-status ts)
(begin
(print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
|
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
|
(print "Header: " header)
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db-get-value-by-header run header (vector-ref k 0))) keys) "/")))
(let* ((run-id (db-get-value-by-header run header "id") )
(tests (db-get-tests-for-run db (db-get-value-by-header run header "id") testpatt itempatt))
(lasttpath #f))
(if (not (null? tests))
(begin
(print "Removing tests for run: " runkey " " (db-get-value-by-header run header "runname"))
(for-each
(lambda (test)
(print " " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test))
(db:delete-test-records db (db:test-get-id test))
|
|
|
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
|
(print "Header: " header)
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db-get-value-by-header run header (vector-ref k 0))) keys) "/")))
(let* ((run-id (db-get-value-by-header run header "id") )
(tests (db-get-tests-for-run db (db-get-value-by-header run header "id") testpatt itempatt))
(lasttpath "/does/not/exist/I/hope"))
(if (not (null? tests))
(begin
(print "Removing tests for run: " runkey " " (db-get-value-by-header run header "runname"))
(for-each
(lambda (test)
(print " " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test))
(db:delete-test-records db (db:test-get-id test))
|