Overview
Comment: | v1.64-cache-issue |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.64-envdebug |
Files: | files | file ages | folders |
SHA1: |
e2ffc3801ed2f73ce246e2220bf24bf4 |
User & Date: | bjbarcla on 2017-03-30 12:30:10 |
Other Links: | branch diff | manifest | tags |
Context
2017-03-31
| ||
16:05 | Added config option dashboard/poll-interval (in milliseconds) for dashboard updates check-in: e7a6790b9b user: mrwellan tags: v1.64-envdebug | |
2017-03-30
| ||
12:30 | v1.64-cache-issue check-in: e2ffc3801e user: bjbarcla tags: v1.64-envdebug | |
2017-03-29
| ||
11:03 | added unlock_db.sh to utils check-in: fd47a3e816 user: bjbarcla tags: v1.64 | |
Changes
Modified api.scm from [d7ff6e57f4] to [9ab20f89e3].
︙ | ︙ | |||
167 168 169 170 171 172 173 174 175 176 177 178 179 180 | ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) ((set-var) (apply db:set-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) | > | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) ((set-var) (apply db:set-var dbstruct params)) ((del-var) (apply db:del-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) |
︙ | ︙ |
Modified common.scm from [735742a8cc] to [675cf742a5].
︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 | (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== | > > > > > > | > > | | 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 | (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== (define (bb-check-path #!key (msg "check-path: ")) (let ((path (or (get-environment-variable "PATH") "none"))) (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) (if (string-match "^.*/isoenv-core/.*" path) (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")) (mungeval (lambda (val) (cond ((eq? val #t) "") ;; convert #t to empty string ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one (else val))))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) |
︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 | (string-intersperse (map (lambda (x) (number->string x 16)) (map string->number (string-split instr))) "/")) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") | > > > > > > > > > > > > > > > > > > | 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 | (string-intersperse (map (lambda (x) (number->string x 16)) (map string->number (string-split instr))) "/")) (define (common:faux-lock keyname) (if (rmt:get-var keyname) #f (begin (rmt:set-var keyname (conc (current-process-id))) (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))))) (define (common:faux-unlock keyname #!key (force #f)) (if (or force (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))) (begin (if (rmt:get-var keyname) (rmt:del-var keyname)) #t) #f)) (define (common:in-running-test?) (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") |
︙ | ︙ |
Modified configf.scm from [e78af9bffb] to [df30172ca7].
︙ | ︙ | |||
661 662 663 664 665 666 667 | (handle-exceptions exn #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) | > | > > | | | > | | | | | | | | | | > > > > > > | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | (handle-exceptions exn #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) (if (common:faux-lock fname) (let* ((dat (configf:config->alist cdat)) (res (begin (with-output-to-file fname ;; first write out the file (lambda () (pp dat))) (if (common:file-exists? fname) ;; now verify it is readable (if (configf:read-alist fname) #t ;; data is good. (begin (handle-exceptions exn #f (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") (delete-file fname)) #f)) #f)))) (common:faux-unlock fname) res) (begin (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname) #f))) ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map (lambda (section) (let ((section-name (car section)) |
︙ | ︙ |
Modified launch.scm from [057f425cdb] to [5116487602].
︙ | ︙ | |||
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 | (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) | > > | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) |
︙ | ︙ | |||
589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | (val (cadr varval))) (if (and (string? var)(string? val)) (begin (setenv var (config:eval-string-in-environment val))) ;; val) (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? work-area) (> count 10)) (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) | > | > > > > > > > | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | (val (cadr varval))) (if (and (string? var)(string? val)) (begin (setenv var (config:eval-string-in-environment val))) ;; val) (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;;(bb-check-path msg: "launch:execute post block 1") ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? work-area) (> count 10)) (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) ;;(bb-check-path msg: "launch:execute post block 1.5") ;; (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 *default-log-port* "varpairs: " varpairs) (map (lambda (varpair) (let ((varval (string-split varpair "="))) (if (eq? (length varval) 2) (let ((var (car varval)) (val (cadr varval))) (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) ;;(bb-check-path msg: "launch:execute post block 2") (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val (setenv var val) (begin (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) ;;(bb-check-path msg: "launch:execute post block 3") (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) ;;(bb-check-path msg: "launch:execute post block 41") (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;;(bb-check-path msg: "launch:execute post block 42") (set-item-env-vars itemdat) ;;(bb-check-path msg: "launch:execute post block 43") (save-environment-as-files "megatest") ;;(bb-check-path msg: "launch:execute post block 44") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here |
︙ | ︙ | |||
760 761 762 763 764 765 766 | (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile) | > | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 | (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile) (if (not (common:in-running-test?)) (configf:write-alist *configdat* tmpfile)) (system (conc "ln -sf " tmpfile " " targfile)))) ))) (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) ;; gather available information, if legit read configs in this order: ;; |
︙ | ︙ | |||
805 806 807 808 809 810 811 812 813 | (runname (common:args-get-runname)) (target (common:args-get-target)) (linktree (common:get-linktree)) (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (rundir (if (and runname target linktree)(conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) #f)) (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) | > | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 | (runname (common:args-get-runname)) (target (common:args-get-target)) (linktree (common:get-linktree)) (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (rundir (if (and runname target linktree)(conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) #f)) (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) (cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir) (not (common:in-running-test?))))) ;; (cxt (hash-table-ref/default *contexts* toppath #f))) ;; create our cxt for this area if it doesn't already exist ;; (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource |
︙ | ︙ |
Modified megatest.scm from [25aeedf27e] to [ca5ad266f7].
︙ | ︙ | |||
855 856 857 858 859 860 861 | key-vals)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin | > | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 | key-vals)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin (if (not (common:in-running-test?)) (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config (launch:setup force: #t) (launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig data)))) (if (args:get-arg "-show-runconfig") (let ((tl (launch:setup))) |
︙ | ︙ |
Modified rmt.scm from [49b292f0a5] to [2cee428d81].
︙ | ︙ | |||
671 672 673 674 675 676 677 678 679 680 681 682 683 684 | (define (rmt:get-main-run-stats run-id) (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== | > > > | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 | (define (rmt:get-main-run-stats run-id) (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) (define (rmt:del-var varname) (rmt:send-receive 'del-var #f (list varname))) (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== |
︙ | ︙ |
Modified runs.scm from [5aecd0eb79] to [d97eca7b82].
︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | hed tal reg reruns test-record test-name item-path jobgroup waitons testmode newtal itemmaps prereqs-not-met) ;; set up needed environment variables given a run-id and optionally a target, itempath etc. ;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) | > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | hed tal reg reruns test-record test-name item-path jobgroup waitons testmode newtal itemmaps prereqs-not-met) ;; set up needed environment variables given a run-id and optionally a target, itempath etc. ;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) |
︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) ;; we had a case where there was an exception generated by the hash-table-ref ;; due to *configdat* being #f Adding a handle and exit | > > > > | > | > > | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) ;; we had a case where there was an exception generated by the hash-table-ref ;; due to *configdat* being #f Adding a handle and exit (let fatal-loop ((count 0)) (handle-exceptions exn (let ((call-chain (get-call-chain)) (msg ((condition-property-accessor 'exn 'message) exn))) (if (< count 5) (begin ;; this call is colliding, do some crude stuff to fix it. (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count) (launch:setup force-reread: #t) (fatal-loop (+ count 1))) (begin (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg) (debug:print 0 *default-log-port* "Call chain:") (with-output-to-port *default-log-port* (lambda ()(pp call-chain))) (exit 1)))) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") (if (and testname link-tree) (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" (getenv "MT_TEST_NAME") (if (and itempath (not (equal? itempath ""))) |
︙ | ︙ |
Modified tests.scm from [5b19c3cd2c] to [92c19920cd].
︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) | > | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 | (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (if (not (common:in-running-test?)) (configf:write-alist tcfg tpath)))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (if (eq? (hash-table-size test-records) 0) '() |
︙ | ︙ |