3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
| 3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
|
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
| res))))
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
;; A routine to map itempaths using a itemmap
;; patha and pathb must be strings or this will fail
;;
(define (db:compare-itempaths patha pathb itemmap)
(debug:print-info 6 "ITEMMAP is " itemmap)
(if itemmap
(let ((pathb-mapped (db:multi-pattern-apply pathb itemmap)))
(debug:print-info 6 "ITEMMAP is " itemmap ", path: " pathb ", mapped path: " pathb-mapped)
(equal? patha pathb-mapped))
(equal? patha pathb)))
(define (db:compare-itempaths patha pathb itemmaps)
(debug:print-info 6 "ITEMMAPS: " itemmaps)
(let* ((testname-a (car (string-split patha "/")))
(itemmap (tests:lookup-itemmap itemmaps testname-a)))
(if itemmap
(let ((pathb-mapped (db:multi-pattern-apply pathb itemmap)))
(debug:print-info 6 "ITEMMAP is " itemmap ", path: " pathb ", mapped path: " pathb-mapped)
(equal? patha pathb-mapped))
(equal? patha pathb))))
;; (let* ((mapparts (string-split itemmap))
;; (pattern (car mapparts))
;; (replacement (if (> (length mapparts) 1) (cadr mapparts) "")))
;; (if replacement
;; (equal? (string-substitute pattern replacement patha)
;; (string-substitute pattern replacement pathb))
;; (equal? (string-substitute pattern "" patha)
;; (string-substitute pattern "" pathb))))
;; A routine to convert test/itempath using a itemmap
;; NOTE: to process only an itempath (i.e. no prepended testname)
;; just call db:multi-pattern-apply
;;
(define (db:convert-test-itempath path-in itemmap)
(debug:print-info 6 "ITEMMAP is " itemmap)
|
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
| 3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
|
-
+
| ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;; mode 'toplevel means that tests must be COMPLETED only
;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;;
;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode itemmap) ;; #!key (mode '(normal))(itemmap #f))
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
(if (or (not waitons)
(null? waitons))
'()
(let* ((unmet-pre-reqs '())
(result '()))
(for-each
(lambda (waitontest-name)
|
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
| 3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
|
-
+
-
+
| (let* ((state (db:test-get-state test))
(status (db:test-get-status test))
(item-path (db:test-get-item-path test))
(is-completed (equal? state "COMPLETED"))
(is-running (equal? state "RUNNING"))
(is-killed (equal? state "KILLED"))
(is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
(same-itempath (db:compare-itempaths item-path ref-item-path itemmap))) ;; (equal? ref-item-path item-path)))
(same-itempath (db:compare-itempaths item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path)))
(set! ever-seen #t)
(cond
;; case 1, non-item (parent test) is
((and (equal? item-path "") ;; this is the parent test of the waiton being examined
is-completed
(or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait))))))
(set! parent-waiton-met #t))
;; Special case for toplevel and KILLED
((and (equal? item-path "") ;; this is the parent test
is-killed
(member 'toplevel mode))
(set! parent-waiton-met #t))
;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))
((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ?????
;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items
same-itempath)
(if (and is-completed is-ok)
(set! item-waiton-met #t))
(if (and (equal? item-path "")
(or is-completed is-running));; this is the parent, set it to run if completed or running
(set! parent-waiton-met #t)))
|