64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
(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)))
;; (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
|
>
>
>
>
>
>
>
|
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
(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
|
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
results)
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! test-id state status comment dat)
(debug:print 4 "INFO: tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat)
(let* ((db #f)
(real-status status)
(otherdat (if dat dat (make-hash-table)))
(testdat (open-run-close db:get-test-info-by-id db test-id))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
|
|
|
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
results)
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! test-id state status comment dat)
(debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat)
(let* ((db #f)
(real-status status)
(otherdat (if dat dat (make-hash-table)))
(testdat (open-run-close db:get-test-info-by-id db test-id))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
|
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
|
(change-directory orig-dir)
(tests:test-set-toplog! db run-id test-name outputfilename)
)))))
(define (get-all-legal-tests)
(let* ((tests (glob (conc *toppath* "/tests/*")))
(res '()))
(debug:print 4 "INFO: Looking at tests " (string-intersperse tests ","))
(for-each (lambda (testpath)
(if (file-exists? (conc testpath "/testconfig"))
(set! res (cons (last (string-split testpath "/")) res))))
tests)
res))
(define (tests:get-testconfig test-name system-allowed)
|
|
|
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
|
(change-directory orig-dir)
(tests:test-set-toplog! db run-id test-name outputfilename)
)))))
(define (get-all-legal-tests)
(let* ((tests (glob (conc *toppath* "/tests/*")))
(res '()))
(debug:print-info 4 "Looking at tests " (string-intersperse tests ","))
(for-each (lambda (testpath)
(if (file-exists? (conc testpath "/testconfig"))
(set! res (cons (last (string-split testpath "/")) res))))
tests)
res))
(define (tests:get-testconfig test-name system-allowed)
|