@@ -26,10 +26,81 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") + +(define (tests:get-valid-tests testsdir test-patts #!key (test-names '())) + (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) + (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) + (delete-duplicates + (append test-names + (filter (lambda (testname) + (tests:match test-patts testname #f)) + (map (lambda (testp) + (last (string-split testp "/"))) + tests)))))) + +;; tests:glob-like-match +(define (tests:glob-like-match patt str) + (let ((like (substring-index "%" patt))) + (let* ((notpatt (equal? (substring-index "~" patt) 0)) + (newpatt (if notpatt (substring patt 1) patt)) + (finpatt (if like + (string-substitute (regexp "%") ".*" newpatt) + (string-substitute (regexp "\\*") ".*" newpatt))) + (res #f)) + ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt) + (set! res (string-match (regexp finpatt (if like #t #f)) str)) + (if notpatt (not res) res)))) + +;; if itempath is #f then look only at the testname part +;; +(define (tests:match patterns testname itempath) + (if (string? patterns) + (let ((patts (string-split patterns ","))) + (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))) + ;; (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)) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found (define (test:get-previous-test-run-record db run-id test-name item-path) (let* ((keys (db:get-keys db)) @@ -54,11 +125,11 @@ ;; if found then return that matching test record (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run db hed test-name item-path '() '()))) + (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '()))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f @@ -92,11 +163,11 @@ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run db hed test-name item-path '() '()))) + (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '()))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat)