Overview
Comment: | Merged fork |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.60 |
Files: | files | file ages | folders |
SHA1: |
482223ee14d1456489d5e380d7da2dcd |
User & Date: | matt on 2015-07-08 21:36:43 |
Other Links: | branch diff | manifest | tags |
Context
2015-07-08
| ||
23:34 | Added TESTPATT in runconfigs test to release suite. Got TESTPATT working correctly check-in: 5551da927c user: matt tags: v1.60 | |
21:36 | Merged fork check-in: 482223ee14 user: matt tags: v1.60 | |
21:35 | Several additons to manual check-in: a8d122521d user: matt tags: v1.60 | |
17:44 | One more missing scenario for using -testpatt check-in: b69f26a9c2 user: mrwellan tags: v1.60, v1.6019 | |
Changes
Modified archive.scm from [d53c0bfed5] to [1e200bee3b].
︙ | ︙ | |||
229 230 231 232 233 234 235 | (archive-block-id (db:test-get-archived test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))) | | > | | | > | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | (archive-block-id (db:test-get-archived test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))) ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children ;; (if (and (not toplevel/children) ;; special handling needed for toplevel with children prev-test-physical-path (file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) (newn (conc base "/." dirn))) (debug:print 0 "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn) (rename-file prev-test-physical-path newn))) (if (and archive-path ;; no point in proceeding if there is no actual archive (not toplevel/children)) (begin ;; CREATE WORK AREA ;; test-src-path == #f ==> don't copy in data from tests directory ;; itemdat == string ==> use directly (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2)) ;; 1. Get the block id from the test info |
︙ | ︙ |
Modified common.scm from [ec352267c4] to [6d03a59ce1].
︙ | ︙ | |||
389 390 391 392 393 394 395 | ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) ;;====================================================================== | | > > > > > > > > > > > > > > > > > > > > | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 | ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== (define (common:args-get-state) (or (args:get-arg "-state")(args:get-arg ":state"))) (define (common:args-get-status) (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt) (let* ((args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (testpatt (or (and (equal? args-testpatt "%") (getenv "TESTPATT")) args-testpatt))) testpatt)) (define (common:args-get-runname) (or (args:get-arg "-runname") (args:get-arg ":runname"))) (define (common:args-get-target #!key (split #f)) (let* ((keys (keys:config-get-fields *configdat*)) (numkeys (length keys)) (target (if (args:get-arg "-reqtarg") (args:get-arg "-reqtarg") (if (args:get-arg "-target") (args:get-arg "-target") |
︙ | ︙ |
Modified launch.scm from [3b16d9aefa] to [e8ae5ca55a].
︙ | ︙ | |||
553 554 555 556 557 558 559 | ))) *toppath*) (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* | > | | 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 | ))) *toppath*) (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") (args:get-arg "-runtests"))) (let* ((linktree (get-environment-variable "MT_LINKTREE")) (target (common:args-get-target)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname"))) (fulldir (conc linktree "/" target "/" runname))) |
︙ | ︙ |
Modified megatest.scm from [2a5ebc4b47] to [953f3e2538].
︙ | ︙ | |||
432 433 434 435 436 437 438 439 440 441 442 443 444 445 | (set! open-run-close open-run-close-no-exception-handling)) (if (args:get-arg "-itempatt") (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== | > > | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 | (set! open-run-close open-run-close-no-exception-handling)) (if (args:get-arg "-itempatt") (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== |
︙ | ︙ | |||
851 852 853 854 855 856 857 | (if (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:operate-on action target | | | | | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 | (if (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:operate-on action target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) (common:args-get-testpatt) ;; (args:get-arg "-testpatt") state: (common:args-get-state) status: (common:args-get-status) new-state-status: (args:get-arg "-set-state-status"))) (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" |
︙ | ︙ | |||
929 930 931 932 933 934 935 | ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup-for-run) (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) | > | | | | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 | ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup-for-run) (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (common:args-get-testpatt)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (db:get-keys dbstruct)) ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment"))) (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) (runs (if (and (not (null? runstmp)) |
︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 | (if (or (args:get-arg "-runall")(args:get-arg "-run")) (general-run-call "-runall" "run all tests" (lambda (target runname keys keyvals) (runs:run-tests target runname | > | | | | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 | (if (or (args:get-arg "-runall")(args:get-arg "-run")) (general-run-call "-runall" "run all tests" (lambda (target runname keys keyvals) (runs:run-tests target runname (common:args-get-testpatt) ;; (or (args:get-arg "-testpatt") ;; "%") user args:arg-hash)))) ;;====================================================================== ;; run one test ;;====================================================================== ;; 1. find the config file ;; 2. change to the test directory ;; 3. update the db with "test started" status, set running host ;; 4. process launch the test ;; - monitor the process, update stats in the db every 2^n minutes ;; 5. as the test proceeds internally it calls megatest as each step is ;; started and completed ;; - step started, timestamp ;; - 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 (or (args:get-arg "-run")(args:get-arg "-runtests")) (general-run-call "-runtests" "run a test" (lambda (target runname keys keyvals) ;; ;; May or may not implement it this way ... ;; ;; Insert this run into the tasks queue ;; (open-run-close tasks:add tasks:open-db ;; "runtests" ;; user ;; target ;; runname ;; (args:get-arg "-runtests") ;; #f)))) (runs:run-tests target runname (common:args-get-testpatt) ;; (args:get-arg "-runtests") user args:arg-hash)))) ;;====================================================================== ;; Rollup into a run ;;====================================================================== |
︙ | ︙ | |||
1602 1603 1604 1605 1606 1607 1608 | (set! *didsomething* #t))) ;;====================================================================== ;; Wait on a run to complete ;;====================================================================== (if (and (args:get-arg "-run-wait") | > | | 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 | (set! *didsomething* #t))) ;;====================================================================== ;; Wait on a run to complete ;;====================================================================== (if (and (args:get-arg "-run-wait") (not (or (args:get-arg "-run") (args:get-arg "-runtests")))) ;; run-wait is built into runtests now (begin (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t))) |
︙ | ︙ | |||
1673 1674 1675 1676 1677 1678 1679 | (if (not *didsomething*) (debug:print 0 help)) (set! *time-to-exit* #t) (thread-join! *watchdog*) (if (not (eq? *globalexitstatus* 0)) | | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 | (if (not *didsomething*) (debug:print 0 help)) (set! *time-to-exit* #t) (thread-join! *watchdog*) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) |
Modified runs.scm from [a18bf25a3a] to [b69da8aa67].
︙ | ︙ | |||
45 46 47 48 49 50 51 | (if (launch:setup-for-run) *configdat* (begin (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") (exit 1))))) (runrec (runs:runrec-make-record)) (target (common:args-get-target)) | | | | | > > > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | (if (launch:setup-for-run) *configdat* (begin (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") (exit 1))))) (runrec (runs:runrec-make-record)) (target (common:args-get-target)) (runname (common:args-get-runname)) (testpatt (common:args-get-testpatt)) ;; (args-testpatt (or (args:get-arg "-testpatt") ;; (args:get-arg "-runtests"))) ;; (testpatt (or (and (equal? args-testpatt "%") ;; (getenv "TESTPATT")) ;; args-testpatt)) (keys (keys:config-get-fields mconfig)) (keyvals (keys:target->keyval keys target)) (toppath *toppath*) (envdat keyvals) ;; initial values start with keyvals (runconfig #f) (serverdat (if (args:get-arg "-server") *runremote* |
︙ | ︙ | |||
82 83 84 85 86 87 88 89 90 91 92 93 94 95 | (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) (if db (sqlite3:finalize! db)) (exit 1))) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) (for-each (lambda (varval) (set! envdat (append envdat (list varval))) (safe-setenv (car varval)(cadr varval))) (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) | > > > > | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) (if db (sqlite3:finalize! db)) (exit 1))) ;; Now have runconfigs data loaded, set environment vars ;; Only now can we calculate the testpatt (set! testpatt (common:args-get-testpatt)) (for-each (lambda (section) (for-each (lambda (varval) (set! envdat (append envdat (list varval))) (safe-setenv (car varval)(cadr varval))) (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) |
︙ | ︙ |