125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
(append (if base-itemmap
(list (list "%" base-itemmap))
'())
(if itemmap-table
itemmap-table
'()))))
;; given a list of itemmaps (testname . map), return the first match
;;
(define (tests:lookup-itemmap itemmaps testname)
(let ((best-matches (filter (lambda (itemmap)
(tests:match (car itemmap) testname #f))
itemmaps)))
(if (null? best-matches)
#f
(let ((res (car best-matches)))
;; (debug:print 0 *default-log-port* "res=" res)
(cond
((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
(define (tests:get-global-waitons rconfig)
(let* ((global-waitons (runconfigs-get rconfig "!GLOBAL_WAITONS")))
(if (string? global-waitons)
(string-split global-waitons)
'())))
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
(append (if base-itemmap
(list (list "%" base-itemmap))
'())
(if itemmap-table
itemmap-table
'()))))
(define (tests:get-global-waitons rconfig)
(let* ((global-waitons (runconfigs-get rconfig "!GLOBAL_WAITONS")))
(if (string? global-waitons)
(string-split global-waitons)
'())))
|
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
|
(else ;; not waiting on items, waiting on entire waiton test.
(let* ((patts (string-split test-patt ","))
(new-patts (if (member waiton-test patts)
patts
(cons waiton-test patts))))
(string-intersperse (delete-duplicates new-patts) ",")))))
(define *glob-like-match-cache* (make-hash-table))
(define (tests:cache-regexp str-in flag)
(let* ((key (conc str-in flag)))
(or (hash-table-ref/default *glob-like-match-cache* key #f)
(let* ((newrx (regexp str-in flag)))
(hash-table-set! *glob-like-match-cache* key newrx)
newrx))))
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let* ((like (substring-index "%" patt))
(notpatt (equal? (substring-index "~" patt) 0))
(newpatt (if notpatt (substring patt 1) patt))
(finpatt (if like
(string-substitute (regexp "%") ".*" newpatt #f)
(string-substitute (regexp "\\*") ".*" newpatt #f)))
(rx (tests:cache-regexp finpatt (if like #t #f)))
(res (string-match rx str)))
(if notpatt (not res) res)))
;; if itempath is #f then look only at the testname part
;;
(define (tests:match patterns testname itempath #!key (required '()))
(if (string? patterns)
(let ((patts (append (string-split patterns ",") required)))
(if (null? patts) ;;; no pattern(s) means no match
#f
(let loop ((patt (car patts))
(tal (cdr patts)))
;; (print "loop: patt: " patt ", tal " tal)
(if (string=? patt "")
#f ;; nothing ever matches empty string - policy
(let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
(test-patt (cadr patt-parts))
(item-patt (cadddr patt-parts)))
;; special case: test vs. test/
;; test => "test" "%"
;; test/ => "test" ""
(if (and (not (substring-index "/" patt)) ;; no slash in the original
(or (not item-patt)
(equal? item-patt ""))) ;; should always be true that item-patt is ""
(set! item-patt "%"))
;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
(if (and (tests:glob-like-match test-patt testname)
(or (not itempath)
(tests:glob-like-match (if item-patt item-patt "") itempath)))
#t
(if (null? tal)
#f
(loop (car tal)(cdr tal)))))))))))
;; if itempath is #f then look only at the testname part
;;
(define (tests:match->sqlqry patterns)
(if (string? patterns)
(let ((patts (string-split patterns ",")))
(if (null? patts) ;;; no pattern(s) means no match, we will do no query
#f
(let loop ((patt (car patts))
(tal (cdr patts))
(res '()))
;; (print "loop: patt: " patt ", tal " tal)
(let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
(test-patt (cadr patt-parts))
(item-patt (cadddr patt-parts))
(test-qry (db:patt->like "testname" test-patt))
(item-qry (db:patt->like "item_path" item-patt))
(qry (conc "(" test-qry " AND " item-qry ")")))
;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
(if (null? tal)
(string-intersperse (append (reverse res)(list qry)) " OR ")
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))
(test-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir testdat)) ;; )
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
277
278
279
280
281
282
283
284
285
286
287
288
289
290
|
(else ;; not waiting on items, waiting on entire waiton test.
(let* ((patts (string-split test-patt ","))
(new-patts (if (member waiton-test patts)
patts
(cons waiton-test patts))))
(string-intersperse (delete-duplicates new-patts) ",")))))
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))
(test-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir testdat)) ;; )
|