Overview
Comment: | Phase 1 of test search path implementation |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | dev |
Files: | files | file ages | folders |
SHA1: |
16e44a18cb47cb7e71e1f7058cf24a3c |
User & Date: | mrwellan on 2013-07-12 11:35:08 |
Other Links: | branch diff | manifest | tags |
Context
2013-07-12
| ||
20:06 | Phase 2 99% done but dashboard still not showing referant tests check-in: da9292b831 user: mrwellan tags: dev | |
11:35 | Phase 1 of test search path implementation check-in: 16e44a18cb user: mrwellan tags: dev | |
2013-07-11
| ||
17:44 | Started hacking the User Manual. Big mess :( check-in: 384db8d983 user: mrwellan tags: dev | |
Changes
Modified configf.scm from [7c7cb15f3e] to [40fcc5a96b].
︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 | ;;====================================================================== (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:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:process-line l ht) | > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | ;;====================================================================== (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 (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:process-line l ht) |
︙ | ︙ | |||
215 216 217 218 219 220 221 222 223 224 225 226 227 228 | (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))) ;; 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" ;; trim lead from the incoming whsp to support some indenting. | > > > > | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | (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" ;; trim lead from the incoming whsp to support some indenting. |
︙ | ︙ |
Modified dashboard.scm from [f215c11c57] to [d867b7fd54].
︙ | ︙ | |||
621 622 623 624 625 626 627 | ;;====================================================================== ;; ;; A gui for launching tests ;; (define (dashboard:run-controls) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) | | > | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 | ;;====================================================================== ;; ;; A gui for launching tests ;; (define (dashboard:run-controls) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (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) (updater-for-runs #f) (update-keyvals (lambda () |
︙ | ︙ |
Modified runs.scm from [d6f3c169a5] to [7a00dd5f7e].
︙ | ︙ | |||
179 180 181 182 183 184 185 | (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)) | > | > | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 | (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))) (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) (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to |
︙ | ︙ | |||
228 229 230 231 232 233 234 | (debug:print-info 8 "waiton procedure results in string " res " for test " hed) res)) ((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) | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | (debug:print-info 8 "waiton procedure results in string " res " for test " hed) res)) ((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 (hash-table-ref/default tests-registry x #f) #t (begin (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x) #f))) newwaitons))))) (debug:print-info 8 "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an |
︙ | ︙ |
Modified tests.scm from [2e17c6b887] to [c81d4cac31].
︙ | ︙ | |||
24 25 26 27 28 29 30 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") | > > > > > > > > > > > | > > > > > > > > > > > | > > > | > < < | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; 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)) (newpatt (if notpatt (substring patt 1) patt)) (finpatt (if like |
︙ | ︙ | |||
439 440 441 442 443 444 445 | (tests:test-set-toplog! db run-id test-name outputfilename) ))))))) ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== | | | | | | | | | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 | (tests:test-set-toplog! db run-id test-name outputfilename) ))))))) ;;====================================================================== ;; 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-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)))) (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed |
︙ | ︙ |
Modified tests/fullrun/megatest.config from [2f912ec36d] to [184b7b1e2f].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | [fields] sysname TEXT fsname TEXT datapath TEXT # refareas can be searched to find previous runs # the path points to where megatest.db exists [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] [setup] # Set launchwait to yes to use the old launch run code that waits for the launch process to return before # proceeding. # launchwait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | [fields] sysname TEXT fsname TEXT datapath TEXT # refareas can be searched to find previous runs # the path points to where megatest.db exists [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 # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. |
︙ | ︙ |