Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -54,10 +54,11 @@ (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) +(define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) ;; read a line and process any #{ ... } constructs @@ -206,22 +207,26 @@ ((return-string) cmd) (else (val-proc))))) (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) (loop (configf:read-line inp res allow-system) curr-section-name #f #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) - (realval (if envar - (config:eval-string-in-environment val) - val))) - (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar - (begin - ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) - (setenv key realval))) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval)) - (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) + (realval (if envar + (config:eval-string-in-environment val) + val))) + (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar + (begin + ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) + (setenv key realval))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval)) + (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key #t)) + (loop (configf:read-line inp res allow-system) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -623,11 +623,12 @@ ;; A gui for launching tests ;; (define (dashboard:run-controls) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) - (test-names (tests:get-valid-tests *toppath* '())) + (test-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) + (test-names (hash-table-keys test-registry)) (sorted-testnames #f) (action "-runtests") (cmdln "") (runlogs (make-hash-table)) (key-listboxes #f) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -174,27 +174,29 @@ ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags) ;; test-names (common:clear-caches) ;; clear all caches - (let* ((keys (keys:config-get-fields *configdat*)) - (keyvals (keys:target->keyval keys target)) - (run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) ;; test-name))) - (deferred '()) ;; delay running these since they have a waiton clause - (runconfigf (conc *toppath* "/runconfigs.config")) - (required-tests '()) - (test-records (make-hash-table)) - (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names + (let* ((keys (keys:config-get-fields *configdat*)) + (keyvals (keys:target->keyval keys target)) + (run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) ;; test-name))) + (deferred '()) ;; delay running these since they have a waiton clause + (runconfigf (conc *toppath* "/runconfigs.config")) + (required-tests '()) + (test-records (make-hash-table)) + (tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names + (all-test-names (hash-table-keys tests-registry)) + (test-names (tests:filter-test-names all-test-names test-patts))) (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (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 (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) + ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) (debug:print-info 0 "test names " test-names) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) @@ -230,11 +232,11 @@ ((string? instr) instr) (else ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) ""))))) (filter (lambda (x) - (if (member x all-test-names) + (if (hash-table-ref/default tests-registry x #f) #t (begin (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x) #f))) newwaitons))))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -26,19 +26,43 @@ (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 - (filter (lambda (testname) - (tests:match test-patts testname #f)) - (map (lambda (testp) - (last (string-split testp "/"))) - tests))))) +;; Call this one to do all the work and get a standardized list of tests +(define (tests:get-all) + (let* ((test-search-path (cons (conc *toppath* "/tests") ;; the default + (tests:get-tests-search-path *configdat*)))) + (tests:get-valid-tests (make-hash-table) test-search-path))) + + +(define (tests:get-tests-search-path cfgdat) + (let ((paths (map car (configf:get-section cfgdat "tests-paths")))) + (cons (conc *toppath* "/tests") paths))) + +(define (tests:get-valid-tests test-registry tests-paths) + (if (null? tests-paths) + test-registry + (let loop ((hed (car tests-paths)) + (tal (cdr tests-paths))) + (if (file-exists? hed) + (for-each (lambda (test-path) + (let* ((tname (last (string-split test-path "/"))) + (tconfig (conc test-path "/testconfig"))) + (if (and (not (hash-table-ref/default test-registry tname #f)) + (file-exists? tconfig)) + (hash-table-set! test-registry tname test-path)))) + (glob (conc hed "/*")))) + (if (null? tal) + test-registry + (loop (car tal)(cdr tal)))))) + +(define (tests:filter-test-names test-names test-patts) + (delete-duplicates + (filter (lambda (testname) + (tests:match test-patts testname #f)) + test-names))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) (let ((like (substring-index "%" patt))) (let* ((notpatt (equal? (substring-index "~" patt) 0)) @@ -441,19 +465,19 @@ ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== -(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 - (filter (lambda (testname) - (tests:match test-patts testname #f)) - (map (lambda (testp) - (last (string-split testp "/"))) - tests))))) +;; (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 +;; (filter (lambda (testname) +;; (tests:match test-patts testname #f)) +;; (map (lambda (testp) +;; (last (string-split testp "/"))) +;; tests))))) (define (tests:get-testconfig test-name system-allowed) (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -8,10 +8,13 @@ [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] +[tests-paths] +#{scheme (nice-path (conc *toppath* "/../simpleruns"))}/tests + [setup] # Set launchwait to yes to use the old launch run code that waits for the launch process to return before # proceeding. # launchwait yes