Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -40,13 +40,12 @@ Usage: megatest [options] -h : this help -version : print megatest version (currently " megatest-version ") Launching and managing runs - -runall : run all tests that are not state COMPLETED and status PASS, - CHECK or KILLED - -runtests tst1,tst2 ... : run tests + -run testpatt[/itempatt] : run all tests that are not state COMPLETED and status PASS, + CHECK or KILLED, matching pattern testpatt... -remove-runs : remove the data for a run, requires :runname and -testpatt Optionally use :state and :status -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rollup : (currently disabled) fill run (set by :runname) with latest test(s) @@ -168,10 +167,11 @@ "-set-state-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all + "-run" ) (list "-h" "-version" "-force" "-xterm" @@ -511,21 +511,40 @@ ;; put task in deferred queue ;; if still ok to run tasks ;; process deferred tasks per above steps ;; run all tests are are Not COMPLETED and PASS or CHECK -(if (args:get-arg "-runall") - (general-run-call - "-runall" - "run all tests" - (lambda (target runname keys keynames keyvallst) - (runs:run-tests target - runname - "%" - (args:get-arg "-testpatt") - user - args:arg-hash)))) +(if (or (args:get-arg "-runall") ;; deprecated + (args:get-arg "-run") + (args:get-arg "-runtests")) + (begin + (if (args:get-arg "-testpatt") + (begin + (debug:print 0 "ERROR:-testpatt is deprecated, use -run patt1,patt2... instead, your pattern " (args:get-arg "-testpatt") " will be ignored") + (sleep 3))) + (if (args:get-arg "-itempatt") + (begin + (debug:print 0 "ERROR: -itempatt is not used with -run, your pattern " (args:get-arg "-itempatt") " will be ignored") + (sleep 3))) + (if (args:get-arg "-runall") + (begin + (debug:print 0 "ERROR: -runall is deprecated, use -run patt1,patt2 ... instead") + (sleep 3))) + (if (args:get-arg "-runtests") + (debug:print 0 "WARNING: -runtests is deprecated, use -run patt1,patt2 ... instead")) + (general-run-call + "-run" + "run tests" + (lambda (target runname keys keynames keyvallst) + (runs:run-tests target + runname + '() + (or (args:get-arg "-run") + (args:get-arg "-runtests") + (args:get-arg "-testpatt")) + user + args:arg-hash))))) ;;====================================================================== ;; run one test ;;====================================================================== @@ -540,21 +559,21 @@ ;; - step completed, exit status, timestamp ;; 6. test phone home ;; - if test run time > allowed run time then kill job ;; - if cannot access db > allowed disconnect time then kill job -(if (args:get-arg "-runtests") - (general-run-call - "-runtests" - "run a test" - (lambda (target runname keys keynames keyvallst) - (runs:run-tests target - runname - (args:get-arg "-runtests") - (args:get-arg "-testpatt") - user - args:arg-hash)))) +;; (if (args:get-arg "-runtests") +;; (general-run-call +;; "-runtests" +;; "run a test" +;; (lambda (target runname keys keynames keyvallst) +;; (runs:run-tests target +;; runname +;; (args:get-arg "-runtests") +;; (args:get-arg "-testpatt") +;; user +;; args:arg-hash)))) ;;====================================================================== ;; Rollup into a run ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -220,11 +220,11 @@ (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) - (set! test-names (tests:get-valid-tests *toppath* test-names)) + (set! test-names (append (tests:get-valid-tests *toppath* test-patts) test-names)) (set! test-names (delete-duplicates test-names)) (debug:print-info 0 "test names " test-names) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if @@ -342,11 +342,12 @@ ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registery (make-hash-table)) (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries"))) + (max-retries (config-lookup *configdat* "setup" "maxretries")) + (dotfilep (if (args:get-arg "-dotfile")(open-output-file (args:get-arg "-dotfile")) #f))) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (if (not (null? sorted-test-names)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reruns '())) @@ -429,11 +430,17 @@ (loop (car newtal)(cdr newtal) reruns)) ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) - (run:test run-id runname keyvallst test-record flags #f) + (if dotfilep + (with-output-to-port (lambda () + (for-each (lambda (w) + (print " " w " -> " test-name ";")) + waitons) + (print " " test-name ";"))) + (run:test run-id runname keyvallst test-record flags #f)) (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) (else ;; must be we have unmet prerequisites (debug:print 4 "FAILS: " fails) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -28,16 +28,21 @@ (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 "%" "*"))))) + (let ((tests (glob (conc testsdir "/tests/*"))) ;; " (string-translate patt "%" "*"))))) + ;; strip off all itempatt portions + (modpat (string-intersperse + (map + (lambda (x)(first (string-split x "/"))) + (string-split test-patts ",")) ","))) (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) (delete-duplicates (filter (lambda (testname) - (tests:match test-patts testname #f)) - (map (lambda (testp) + (tests:match modpat testname #f)) + (map (lambda (testp) ;; extract the testname from /testconfig (last (string-split testp "/"))) tests))))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -45,24 +45,39 @@ (for-each (lambda (patt str expected) (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str))) (list "abc" "~abc" "~abc" "a*c" "a%c") (list "abc" "abcd" "abc" "ABC" "ABC") - (list '("abc") #t #f #f '("ABC")) - ) + (list '("abc") #t #f #f '("ABC"))) + +(test #f '("sqlite3speed") (tests:get-valid-tests *toppath* "%sqlite%") ) ;; tests:match (test #f #t (tests:match "abc/def" "abc" "def")) (for-each - (lambda (patterns testname itempath expected) - (test (conc patterns " " testname "/" itempath "=>" expected) - expected - (tests:match patterns testname itempath))) - (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/") - (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a") - (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b") - (list #t #t #t #f #f #t #t #t #f #t #t #t #f)) + (lambda (row) ;; erns testname itempath expected) + (let ((patterns (list-ref row 0)) + (testname (list-ref row 1)) + (itempath (list-ref row 2)) + (expected (list-ref row 3))) + (test (conc patterns " " testname "/" itempath "=>" expected) + expected + (tests:match patterns testname itempath)))) + '(("abc" "abc" "" #t) + ("abc/%" "abc" "" #t) + ("ab%/c%" "abcd" "cde" #t) + ("ab%/c%" "def" "" #t) + ("~abc/c%" "abc" "cde" #f) + ("abc/~c%" "abc" "cde" #f) + ("a,b/c,%/d" "a" "" #t) + ("%/,%/a" "abc" "" #t) + ("%/,%/a" "def" "a" #t) + ("%/,%/a" "ghi" "b" #f) + ("%" "a" "" #t) + ("%" "a" "b" #t) + ("%/" "a" "" #t) + ("%/" "a" "b" #f))) ;; db:patt->like (test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND ")) (test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND ")) (test #f "item_path GLOB ''" (db:patt->like "item_path" "")) @@ -70,10 +85,12 @@ ;; test:match->sqlqry (test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')" (tests:match->sqlqry "a/b,a%,/b%")) (test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')" (tests:match->sqlqry "a/b,a%,%/b%")) + +(exit) ;;====================================================================== ;; S E R V E R ;;======================================================================