Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -81,11 +81,10 @@ get-run-state get-run-stats get-run-times get-targets get-target - ;; register-run get-tests-tags get-test-times get-tests-for-run get-tests-for-run-state-status get-test-id @@ -359,11 +358,11 @@ ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) - (db:general-call dbstruct stmtname realparams))) + (db:general-call dbstruct stmtname run-id realparams))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) ;; TESTMETA @@ -412,21 +411,22 @@ (define (api:process-request dbstruct indat) ;; the $ is the request vars proc (let* ((cmd-in (alist-ref 'cmd indat)) ;; ($ 'cmd)) (cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in)) (params (alist-ref 'params indat)) (key (alist-ref 'key indat)) ;; TODO - add this back + (doprint (apply common:low-noise-print 10 params)) ) - (debug:print 0 *default-log-port* "cmd:" cmd " with params " params ", key " key) + (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key)) (case cmd-in ((ping) #t) ;; ((quit) (exit)) (else (if (equal? key *my-signature*) ;; TODO - get real key involved (begin (set! *api-process-request-count* (+ *api-process-request-count* 1)) (let* ((res (api:execute-requests dbstruct cmd params))) - (debug:print 0 *default-log-port* "res:" res) + (if doprint (debug:print 0 *default-log-port* "res:" res)) #;(if (not success) (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) (if (> *api-process-request-count* *max-api-process-requests*) (set! *max-api-process-requests* *api-process-request-count*)) (set! *api-process-request-count* (- *api-process-request-count* 1)) Index: archivemod.scm ================================================================== --- archivemod.scm +++ archivemod.scm @@ -223,11 +223,11 @@ (if s (string->symbol s) 'bup))) (archiver-cmd (case archiver ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ") ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ") (else #f))) - (src-archive-linktree (rmt:get-var "src-archive-linktree")) + (src-archive-linktree (rmt:get-var run-id "src-archive-linktree")) (print-prefix "Running: ") ;; change to #f to turn off printing (preclean-spec (configf:get-section *configdat* "archive-preclean"))) (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree))) (rmt:set-var "src-archive-linktree" linktree)) @@ -481,11 +481,11 @@ 'old2new ) (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") (rmt:drop-all-triggers) (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) - (src-archive-linktree (rmt:get-var "src-archive-linktree"))) + (src-archive-linktree (rmt:get-var #f "src-archive-linktree"))) (if (not (equal? src-archive-linktree linktree)) (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree)) (debug:print-info 1 *default-log-port* "creating triggers after updating linktree") (rmt:create-all-triggers) )) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -108,12 +108,12 @@ (define *bdat* #f) ;; the one and only (someday) global? (defstruct bdat - (home (getenv "HOME")) - (user (getenv "USER")) + (home (get-environment-variable "HOME")) + (user (get-environment-variable "USER")) (watchdog #f) (time-to-exit #f) (task-db #f) (target #f) (this-exe-fullpath #f) @@ -153,12 +153,12 @@ (set-signal-handler! signal/term std-signal-handler) ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! bdat)) -;; (define home (getenv "HOME")) -;; (define user (getenv "USER")) +;; (define home (get-environment-variable "HOME")) +;; (define user (get-environment-variable "USER")) (define keys:config-get-fields common:get-fields) ;; Globals ;; ;;(define *server-loop-heart-beat* (current-seconds)) @@ -171,11 +171,11 @@ (define *db-keys* #f) (define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data -;; (define *configdat* #f) ;; megatest.config data ==> moved to configfmod +(define *configdat* #f) ;; megatest.config data ==> moved to configfmod (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *test-meta-updated* (make-hash-table)) @@ -406,20 +406,20 @@ (dynamic-wind (lambda () (void)) (lambda () ;; (use posix) (for-each (lambda (var-value) - (setenv (car var-value) (cdr var-value))) + (set-environment-variable! (car var-value) (cdr var-value))) variables) (thunk)) (lambda () (for-each (lambda (var-value) (let ((var (car var-value)) (value (cdr var-value))) (if value - (setenv var value) - (unsetenv var)))) + (set-environment-variable! var value) + (unset-environment-variable! var)))) pre-existing-variables))))) ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock @@ -900,11 +900,11 @@ (hash-table-set! *common:denoise* key currtime) #t) #f))) (define (common:get-megatest-exe) - (or (getenv "MT_MEGATEST") "megatest")) + (or (get-environment-variable "MT_MEGATEST") "megatest")) (define (common:read-encoded-string instr) (handle-exceptions exn (handle-exceptions @@ -989,11 +989,11 @@ (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-area-name) (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. (configf:lookup *configdat* "setup" "testsuite" ) - (getenv "MT_TESTSUITE_NAME") + (get-environment-variable "MT_TESTSUITE_NAME") (pathname-file (or (if (string? *toppath* ) (pathname-file *toppath*) #f) (common:get-toppath #f))) "please-set-setup-area-name")) ;; (pathname-file (current-directory))))) @@ -1003,16 +1003,16 @@ (define (common:get-toppath areapath) (or *toppath* (if areapath (begin (set! *toppath* areapath) - (setenv "MT_RUN_AREA_HOME" areapath) + (set-environment-variable! "MT_RUN_AREA_HOME" areapath) areapath) #f) - (if (getenv "MT_RUN_AREA_HOME") + (if (get-environment-variable "MT_RUN_AREA_HOME") (begin - (set! *toppath* (getenv "MT_RUN_AREA_HOME")) + (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) *toppath*) #f) ;; last resort, look for megatest.config (let loop ((thepath (realpath "."))) (if (file-exists? (conc thepath "/megatest.config")) @@ -1253,36 +1253,27 @@ (filter (lambda (x) (patt-list-match x target-patt)) targs) targs))) -;;====================================================================== -;; Lookup a value in runconfigs based on -reqtarg or -target -;; -(define (runconfigs-get config var) - (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) - (if targ - (or (configf:lookup config targ var) - (configf:lookup config "default" var)) - (configf:lookup config "default" var)))) - (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 rconf) - (let* (;; (tagexpr (args:get-arg "-tagexpr")) + (let* ((target (common:args-get-target)) + ;; (tagexpr (args:get-arg "-tagexpr")) ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) - (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) + (rtestpatt (if rconf (runconfigs-get rconf target testpatt-key) #f))) (cond ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig (if rconf - (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key))) + (let* ((patts-from-mode-patt (runconfigs-get rconf target testpatt-key))) (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) patts-from-mode-patt) (begin (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt) #f))) ;; We do NOT fall back to "%" @@ -1332,35 +1323,35 @@ (file-writable? path-string)) path-string #f))) (define (common:get-linktree) - (or (getenv "MT_LINKTREE") + (or (get-environment-variable "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f) - (if (or *toppath* (getenv "MT_RUN_AREA_HOME")) - (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt") + (if (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) + (conc (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) "/lt") #f) (let* ((tp (common:get-toppath #f)) (lt (conc tp "/lt"))) (if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt)) lt))) (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") - (getenv "MT_RUNNAME")))) - ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... + (get-environment-variable "MT_RUNNAME")))) + ;; (if res (set-environment-variable! "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") - (getenv "MT_TARGET"))) + (get-environment-variable "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) (valid (if target (or (null? keys) ;; probably don't know our keys yet (and (not (null? tlist)) (eq? numkeys (length tlist)) @@ -1379,15 +1370,15 @@ ;;====================================================================== ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) - (if (getenv "MT_TEST_NAME") - (if (and (getenv "MT_ITEMPATH") - (not (equal? (getenv "MT_ITEMPATH") ""))) - (getenv "MT_TEST_NAME") - (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) + (if (get-environment-variable "MT_TEST_NAME") + (if (and (get-environment-variable "MT_ITEMPATH") + (not (equal? (get-environment-variable "MT_ITEMPATH") ""))) + (get-environment-variable "MT_TEST_NAME") + (conc (get-environment-variable "MT_TEST_NAME") "/" (get-environment-variable "MT_ITEMPATH"))) #f)) ;;====================================================================== ;; do we honor the caches of the config files? ;; @@ -1397,14 +1388,14 @@ (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") (set! res #f) (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") (set! res #t)))) (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" - (if (getenv "MT_USE_CACHE") - (if (equal? (getenv "MT_USE_CACHE") "yes") + (if (get-environment-variable "MT_USE_CACHE") + (if (equal? (get-environment-variable "MT_USE_CACHE") "yes") (set! res #t) - (if (equal? (getenv "MT_USE_CACHE") "no") + (if (equal? (get-environment-variable "MT_USE_CACHE") "no") (set! res #f)))) ;; overrides -no-cache switch res)) ;;====================================================================== ;; force use of server? @@ -2059,27 +2050,27 @@ ;; no elegance here ... ;; (define (tasks:kill-server hostname pid #!key (kill-switch "")) (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) - (setenv "TARGETHOST" hostname) + (set-environment-variable! "TARGETHOST" hostname) (let* ((logdir (if (directory-exists? "logs") "logs/" "")) (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f)) (gzfile (if logfile (conc logfile ".gz")))) - (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log")) + (set-environment-variable! "TARGETHOST_LOGF" (conc logdir "server-kills.log")) (system (conc "nbfake kill "kill-switch" "pid)) (when logfile (thread-sleep! 0.5) (if (file-exists? gzfile) (delete-file gzfile)) (system (conc "gzip " logfile)) - (unsetenv "TARGETHOST_LOGF") - (unsetenv "TARGETHOST")))) + (unset-environment-variable! "TARGETHOST_LOGF") + (unset-environment-variable! "TARGETHOST")))) (define (server:get-logs-list area-path) (let* (;; (server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log")) ;; (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string)))) (server-logs (glob (conc area-path"/logs/server-*-*.log"))) @@ -2711,11 +2702,11 @@ (val (cadr p)) (prv (get-environment-variable var))) (set! res (cons (list var prv) res)) (if val (safe-setenv var (->string val)) - (unsetenv var)))) + (unset-environment-variable! var)))) lst) res) '())) ;;====================================================================== @@ -2735,17 +2726,17 @@ x)) envvars)))) (define (common:with-orig-env proc) (let ((current-env (get-environment-variables))) - (for-each (lambda (x) (unsetenv (car x))) current-env) - (for-each (lambda (x) (setenv (car x) (cdr x))) (bdat-orig-env *bdat*)) + (for-each (lambda (x) (unset-environment-variable! (car x))) current-env) + (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) (bdat-orig-env *bdat*)) (let ((rv (cond ((string? proc)(system proc)) (proc (proc))))) - (for-each (lambda (x) (unsetenv (car x))) (bdat-orig-env *bdat*)) - (for-each (lambda (x) (setenv (car x) (cdr x))) current-env) + (for-each (lambda (x) (unset-environment-variable! (car x))) (bdat-orig-env *bdat*)) + (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) current-env) rv))) (define (common:without-vars proc . var-patts) (let ((vars (make-hash-table))) (for-each @@ -2754,20 +2745,20 @@ (lambda (var-patt) (if (string-match var-patt (car vardat)) (let ((var (car vardat)) (val (cdr vardat))) (hash-table-set! vars var val) - (unsetenv var)))) + (unset-environment-variable! var)))) var-patts)) (get-environment-variables)) (cond ((string? proc)(system proc)) (proc (proc))) (hash-table-for-each vars (lambda (var val) - (setenv var val))) + (set-environment-variable! var val))) vars)) (define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -22,11 +22,41 @@ (declare (uses mtargs)) (declare (uses debugprint)) (declare (uses keysmod)) (module configfmod - * + ( + common:get-fields + common:nice-path + common:read-link-f + common:with-env-vars + configf:config->ini + configf:alist->config + configf:assoc-safe-add + configf:config->alist + configf:find-and-read-config + configf:get-section + configf:lookup + configf:lookup-number + configf:map-all-hier-alist + configf:read-alist + configf:read-config + configf:read-refdb + configf:section-var-set! + configf:section-vars + configf:set-section-var + configf:var-is? + configf:write-alist + configf:write-config + find-config + nice-path + process:cmd-run->list + runconfig:read + runconfigs-get + safe-setenv + configf:eval-string-in-environment + ) (import scheme chicken.base chicken.condition @@ -67,12 +97,10 @@ typed-records z3 ) -(define *configdat* #f) - (define getenv get-environment-variable) (define setenv set-environment-variable!) (define unsetenv unset-environment-variable!) ;;====================================================================== @@ -954,14 +982,81 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== ;; convert to param? -(define configf:std-imports "") ;;(import configfmod commonmod)") - +(define configf:std-imports "(import configfmod commonmod)") +(define (configf:process-one matchdat l ht allow-system env-to-use linenum) + (let* ((prestr (list-ref matchdat 1)) + (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv + (cmd (list-ref matchdat 3)) + (quotedcmd (conc "\""cmd"\"")) + (poststr (list-ref matchdat 4)) + (result #f) + (start-time (current-seconds)) + (cmdsym (string->symbol cmdtype)) + (fullcmd + (if (member cmdsym '(scheme scm)) + `(eval-needed + ,(conc configf:std-imports + "(import chicken.process-context.posix chicken.process-context)" + "(define setenv set-environment-variable)" + (conc "(lambda (ht)" cmd ")"))) + (case cmdsym + ((system) `(noeval-needed ,(conc (configf:system ht quotedcmd)))) + ((shell sh) `(noeval-needed ,(conc (string-translate (shell quotedcmd) "\n" " ")))) + ((realpath rp)`(noeval-needed ,(conc (common:nice-path quotedcmd)))) + ((getenv gv) `(noeval-needed ,(conc (get-environment-variable cmd)))) + ;; ((mtrah) (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\")))) + ((get g) + (match + (string-split cmd) + ((sect var)(configf:lookup ht sect var)) + (else + (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") + '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed."))))) + ((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + (else `(#f ,(conc "cmd: " cmd " not recognised"))))))) + (match + fullcmd + (('eval-needed newres) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", fullcmd="fullcmd", exn=" exn) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) + (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) + (if (or allow-system + (not (member cmdtype '("system" "shell" "sh")))) + (with-input-from-string newres + (lambda () + (set! result (if env-to-use + ((eval (read) env-to-use) ht) + ((eval (read)) ht) + )))) + (set! result (conc "#{(" cmdtype ") " cmd "}"))))) + (('noeval-needed newres)(set! result newres)) + ((#f errres) + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"."))) + ;; we process as a result + (let ((delta (- (current-seconds) start-time))) + (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)) + (conc prestr result poststr))) + (define (configf:process-line l ht allow-system env-to-use #!key (linenum #f)) (let loop ((res l)) + (if (string? res) + (let ((matchdat (string-search configf:var-expand-regex res))) + (if matchdat + (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum))) + (loop result)) + res)) + res))) + +(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f)) + (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv @@ -1019,11 +1114,21 @@ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) (loop (conc prestr result poststr))) res)) res))) - +;;====================================================================== +;; Lookup a value in runconfigs based on -reqtarg or -target +;; +(define (runconfigs-get config target var) + (let ((targ target #;(common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) + (if targ + (or (configf:lookup config targ var) + (configf:lookup config "default" var)) + (configf:lookup config "default" var)))) + + ;; pathenvvar will set the named var to the path of the config (define (configf:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(env-to-use #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -102,17 +102,17 @@ (last-sync 0) (last-write (current-seconds)) (run-id #f) (fname #f)) -;; Returns the dbdat for a particular run-id from dbstruct +;; Returns the dbdat for a particular dbfile inside the area ;; -(define (dbr:dbstruct-get-dbdat v run-id) - (hash-table-ref/default (dbr:dbstruct-dbdats v) run-id #f)) +(define (dbr:dbstruct-get-dbdat dbstruct dbfile) + (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f)) -(define (dbr:dbstruct-dbdat-put! v run-id db) - (hash-table-set! (dbr:dbstruct-dbdats v) run-id db)) +(define (dbr:dbstruct-dbdat-put! dbstruct dbfile db) + (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db)) (define (db:run-id->first-num run-id) (let* ((s (number->string run-id)) (l (string-length s))) (substring s (- l 1) l))) @@ -155,15 +155,14 @@ ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-dbdat dbstruct apath dbfile) - (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id))) + (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) (if dbdat dbdat - (let* (;; (dbfile (db:run-id->path apath run-id)) - (newdbdat (db:open-dbdat apath dbfile db:initialize-db))) + (let* ((newdbdat (db:open-dbdat apath dbfile db:initialize-db))) (dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat) newdbdat)))) ;; get the inmem db for actual db operations ;; @@ -178,12 +177,11 @@ ;; open or create the disk db file ;; create and fill the inmemory db ;; assemble into dbr:dbdat struct and return ;; (define (db:open-dbdat apath dbfile dbinit-proc) - (let* (;; (dbfile (db:run-id->path apath run-id)) - (db (db:open-run-db dbfile dbinit-proc)) + (let* ((db (db:open-run-db dbfile dbinit-proc)) ;; (inmem (db:open-inmem-db dbinit-proc)) (dbdat (make-dbr:dbdat db: #f ;; db inmem: db ;; inmem ;; run-id: run-id ;; no can do, there are many run-id values that point to single db @@ -191,12 +189,11 @@ ;; now sync the disk file data into the inmemory db ;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem) ;; (sqlite3:finalize! db) ;; open and close every sync dbdat)) ;; (define (db:open-dbdat apath dbfile dbinit-proc) -;; (let* (;; (dbfile (db:run-id->path apath run-id)) -;; (db (db:open-run-db dbfile dbinit-proc)) +;; (let* ((db (db:open-run-db dbfile dbinit-proc)) ;; (inmem (db:open-inmem-db dbinit-proc)) ;; (dbdat (make-dbr:dbdat ;; db: #f ;; db ;; inmem: inmem ;; ;; run-id: run-id ;; no can do, there are many run-id values that point to single db @@ -231,24 +228,24 @@ (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db) db)) -;; for debugging we have a local mode. these routines support that mode -(define *dbcache* (make-hash-table)) - -(define (db:cache-get-dbstruct rid apath) - (let* ((dbname (db:run-id->dbname rid)) - (dbfile (db:dbname->path apath dbname))) - (or (hash-table-ref/default *dbcache* dbfile #f) - (let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db))) - (hash-table-set! *dbcache* dbfile dbstruct) - dbstruct)))) - -(define (db:finalize-all-cache-dbstruct) - #f) - +;; ;; for debugging we have a local mode. these routines support that mode +;; (define *dbcache* (make-hash-table)) +;; +;; (define (db:cache-get-dbstruct rid apath) +;; (let* ((dbname (db:run-id->dbname rid)) +;; (dbfile (db:dbname->path apath dbname))) +;; (or (hash-table-ref/default *dbcache* dbfile #f) +;; (let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db))) +;; (hash-table-set! *dbcache* dbfile dbstruct) +;; dbstruct)))) +;; +;; (define (db:finalize-all-cache-dbstruct) +;; #f) +;; ;; get and initalize dbstruct for a given run-id ;; ;; - uses db:initialize-db to create the schema ;; @@ -257,12 +254,11 @@ ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; (define (db:setup db-file) ;; run-id) (assert *toppath* "FATAL: db:setup called before toppath is available.") - (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))) - #;(db-file (db:run-id->path *toppath* run-id))) + (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))) (db:get-dbdat dbstruct *toppath* db-file) (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct)) dbstruct)) ;;====================================================================== @@ -1196,24 +1192,24 @@ BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ))) -(define (db:create-all-triggers dbstruct) +(define (db:create-all-triggers dbstruct run-id) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (db:create-triggers db)))) (define (db:create-triggers db) (for-each (lambda (key) (sqlite3:execute db (cadr key))) db:trigger-list)) -(define (db:drop-all-triggers dbstruct) +(define (db:drop-all-triggers dbstruct run-id) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (db:drop-triggers db)))) (define (db:is-trigger-dropped db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") @@ -1642,11 +1638,11 @@ (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 72000))) ;; twenty hours (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; @@ -1725,11 +1721,11 @@ ) (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (let* ((stmth1 (db:get-cache-stmth dbstruct db "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) @@ -1847,11 +1843,11 @@ ))))))) ;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) - (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) + (db:general-call dbstruct 'top-test-set-per-pf-counts run-id (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1997,18 +1993,18 @@ ;; dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== - + ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; -(define (db:get-var dbstruct var) +(define (db:get-var dbstruct run-id var) (let* ((res #f)) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (val) (set! res val)) db @@ -2017,17 +2013,17 @@ (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) res)))) -(define (db:inc-var dbstruct var) - (db:with-db dbstruct #f #t +(define (db:inc-var dbstruct run-id var) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var)))) -(define (db:dec-var dbstruct var) - (db:with-db dbstruct #f #t +(define (db:dec-var dbstruct run-id var) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var)))) ;; This was part of db:get-var. It was used to estimate the load on ;; the database files. @@ -2039,22 +2035,22 @@ ;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit ;; (begin ;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) -(define (db:set-var dbstruct var val) - (db:with-db dbstruct #f #t +(define (db:set-var dbstruct run-id var val) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) -(define (db:add-var dbstruct var val) - (db:with-db dbstruct #f #t +(define (db:add-var dbstruct run-id var val) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var)))) -(define (db:del-var dbstruct var) - (db:with-db dbstruct #f #t +(define (db:del-var dbstruct run-id var) + (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers @@ -2278,12 +2274,11 @@ res))) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) -;; register a test run with the db, this accesses the main.db and does NOT -;; use server api +;; register a run with the db ;; (define (db:insert-run dbstruct run-id keyvals runname state status user contour-in) (let* ((keys (map car keyvals)) (keystr (keys->keystr keys)) (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. @@ -2295,11 +2290,11 @@ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (id,runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,?,strftime('%s','now'),?" comma valslots ");") run-id allvals) @@ -2521,11 +2516,11 @@ ;; (define (db:update-run-stats dbstruct run-id stats) ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct - #f + run-id #f (lambda (db) ;; remove previous data @@ -3078,14 +3073,14 @@ ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) - (db:general-call dbstruct 'delete-test-step-records (list test-id)) - (db:general-call dbstruct 'delete-test-data-records (list test-id)) + (db:general-call dbstruct 'delete-test-step-records run-id (list test-id)) + (db:general-call dbstruct 'delete-test-data-records run-id (list test-id)) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))) ;; (define (db:delete-old-deleted-test-records dbstruct) @@ -3140,31 +3135,25 @@ test-ids)) ;; ;; speed up for common cases with a little logic ;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id ;; +;; NOTE: processing triggers was called here - moved upstream +;; ;; NOTE: run-id is not used ;; ;; -(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment) - (db:with-db - dbstruct - ;; run-id - #f - #t - (lambda (db) - (cond - ((and newstate newstatus newcomment) - (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment) - test-id)) - ((and newstate newstatus) - (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) - (else - (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) - (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) - (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment) - test-id)))))) - (mt:process-triggers dbstruct run-id test-id newstate newstatus)) +(define (db:test-set-state-status db run-id test-id newstate newstatus newcomment) + (cond + ((and newstate newstatus newcomment) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment) + test-id)) + ((and newstate newstatus) + (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) + (else + (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) + (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) + (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))) ;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) ;; fastmode) (let* ((qry ;; (if fastmode @@ -3617,13 +3606,13 @@ db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; Now rollup the counts to the central megatest.db - (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id)) + (db:general-call dbstruct 'pass-fail-counts run-id (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. - (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id)))))) + (db:general-call dbstruct 'test_data-pf-rollup run-id (list test-id test-id test-id test-id)))))) ;; each section is a rule except "final" which is the final result ;; ;; [rule-5] ;; operator in @@ -3924,40 +3913,44 @@ (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (if tl-testdat (db:test-get-id tl-testdat) #f))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call dbstruct 'set-test-start-time (list test-id))) - (mutex-lock! *db-transaction-mutex*) + (db:general-call dbstruct 'set-test-start-time run-id (list test-id))) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (let ((tr-res (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction - (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status + ;; this call sets the item state/status + (db:test-set-state-status db run-id test-id state status comment) (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test (state-stauses (db:roll-up-rules state-status-counts state status)) (newstate (car state-stauses)) (newstatus (cadr state-stauses))) (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: " (apply conc (map (lambda (x) (conc - (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) - state-status-counts))); end debug:print - + (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) + state-status-counts))); end debug:print + (if tl-test-id (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct )))))) - (mutex-unlock! *db-transaction-mutex*) + ;; (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) - tr-res))))) + tr-res))) + ;; this was moved out of test-set-state-status + (mt:process-triggers dbstruct run-id test-id state status))) + (define (db:roll-up-rules state-status-counts state status) (let* ((running (length (filter (lambda (x) (member (dbr:counts-state x) *common:running-states*)) state-status-counts))) @@ -4012,11 +4005,11 @@ ;; NB// Pass the db so it is part of the transaction (list newstate newstatus))) (define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status) - (mutex-lock! *db-transaction-mutex*) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f (lambda (db) (let ((tr-res (sqlite3:with-transaction @@ -4026,11 +4019,11 @@ (state-stauses (db:roll-up-rules state-status-counts #f #f )) (newstate (car state-stauses)) (newstatus (cadr state-stauses))) (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) (db:set-run-state-status dbstruct run-id newstate newstatus ))))))) - (mutex-unlock! *db-transaction-mutex*) + ;; (mutex-unlock! *db-transaction-mutex*) tr-res)))) (define (db:get-all-state-status-counts-for-run dbstruct run-id) (let* ((test-count-recs (db:with-db @@ -4288,18 +4281,18 @@ (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call dbstruct stmtname params) +(define (db:general-call dbstruct stmtname run-id params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) (db:with-db - dbstruct #f #f + dbstruct run-id #f (lambda (db) (apply sqlite3:execute db query params) #t)))) ;; get a summary of state and status counts to calculate a rollup @@ -5211,11 +5204,11 @@ actual-state " " actual-status " " event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) - (setenv "NBFAKE_LOG" (conc (cond + (set-environment-variable! "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) (file-writable? test-rundir)) test-rundir) ((and (directory-exists? *toppath*) (file-writable? *toppath*)) @@ -5226,12 +5219,12 @@ ;; (call-with-environment-variables ;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname))) ;; (lambda () (process-run fullcmd) (if prev-nbfake-log - (setenv "NBFAKE_LOG" prev-nbfake-log) - (unsetenv "NBFAKE_LOG")) + (set-environment-variable! "NBFAKE_LOG" prev-nbfake-log) + (unset-environment-variable! "NBFAKE_LOG")) )) ;; )) (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (if test-id (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) @@ -5303,16 +5296,16 @@ (if (and (common:file-exists? tconfig-file) (file-readable? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE")) (bigmodenv (module-environment 'bigmod))) - (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) + (if link-tree-path (set-environment-variable! "MT_LINKTREE" link-tree-path)) (let ((newtcfg (configf:read-config tconfig-file #f #f env-to-use: bigmodenv))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) (if old-link-tree - (setenv "MT_LINKTREE" old-link-tree) - (unsetenv "MT_LINKTREE")) + (set-environment-variable! "MT_LINKTREE" old-link-tree) + (unset-environment-variable! "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -141,11 +141,11 @@ ;; (print "COMMON: " (string-intersperse common-parts "\n ")) (string-intersperse final separator))) (define (env:process-path-envvar varname separator patha pathb) (let ((newpath (env:merge-path-envvar separator patha pathb))) - (setenv varname newpath))) + (set-environment-variable! varname newpath))) (define (env:have-context db context) (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) 0)) Index: ezstepsmod.scm ================================================================== --- ezstepsmod.scm +++ ezstepsmod.scm @@ -132,11 +132,11 @@ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (common:file-exists? logpro-file))) - (setenv "MT_STEP_NAME" stepname) + (set-environment-variable! "MT_STEP_NAME" stepname) (hash-table-set! all-steps-dat stepname `((params . ,paramparts))) (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd) (if (and tconfig-logpro @@ -203,11 +203,11 @@ (processloop (+ i 1)))) ))))) (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) ;; now run logpro if needed (if logpro-used - (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro")) + (let* ((logpro-exe (or (get-environment-variable "LOGPRO_EXE") "logpro")) (pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'")))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code) Index: launchmod.scm ================================================================== --- launchmod.scm +++ launchmod.scm @@ -125,11 +125,11 @@ (debug:print 0 *default-log-port* "keep-going=" keep-going) (and keep-going (equal? (car keep-going) "yes"))))) ;; if handed a string, process it, else look for MT_CMDINFO (define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) - (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) + (let ((enccmd (if encoded-cmd encoded-cmd (get-environment-variable "MT_CMDINFO")))) (if enccmd (common:read-encoded-string enccmd) '()))) (define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m) @@ -218,11 +218,11 @@ ;; check exit-info (vector-ref exit-info 1) (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) (let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)) (stepname (car ezstep)) (stepparms (hash-table-ref all-steps-dat stepname))) - (setenv "MT_STEP_NAME" stepname) + (set-environment-variable! "MT_STEP_NAME" stepname) (pp (hash-table->alist all-steps-dat)) ;; if logpro-used read in the stepname.dat file (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) (launch:load-logpro-dat run-id test-id stepname)) (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms) @@ -286,11 +286,11 @@ (set! kill-job? #f))) (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync) (launch:handle-zombie-tests run-id) (when do-sync - ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append) + ;;(with-output-to-file (conc (get-environment-variable "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append) ;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes))))) ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds))) (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds))) ) @@ -355,11 +355,11 @@ (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) - (setenv "MT_CMDINFO" encoded-cmd) + (set-environment-variable! "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)) @@ -434,31 +434,31 @@ (launch:test-copy testpath work-area)))) ;; one more time, change to the work-area directory (change-directory work-area))) ) ;; let* - (if contour (setenv "MT_CONTOUR" contour)) + (if contour (set-environment-variable! "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) + (set-environment-variable! "MT_TESTSUITENAME" areaname) + (set-environment-variable! "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) + (set-environment-variable! "MT_TEST_RUN_DIR" work-area) (launch:setup) ;; should be properly in the run area home now - (if contour (setenv "MT_CONTOUR" contour)) + (if contour (set-environment-variable! "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) + (set-environment-variable! "MT_TESTSUITENAME" areaname) + (set-environment-variable! "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) + (set-environment-variable! "MT_TEST_RUN_DIR" work-area) (launch:setup) ;; should be properly in the run area home now (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path (let ((sighand (lambda (signum) @@ -592,19 +592,19 @@ (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))))) + (set-environment-variable! 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) + (set-environment-variable! 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) @@ -616,11 +616,11 @@ (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-area-name)))) ;;(bb-check-path msg: "launch:execute post block 3") - (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) + (if mt-bindir-path (set-environment-variable! "PATH" (conc (get-environment-variable "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) @@ -635,11 +635,11 @@ (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) (if blacklist (let ((vars (string-split blacklist))) (save-environment-as-files "megatest" ignorevars: vars) (for-each (lambda (var) - (unsetenv var)) + (unset-environment-variable! var)) vars)) (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) @@ -768,11 +768,11 @@ (args:get-arg "-execute"))) (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE")) (target (common:args-get-target exit-if-bad: #t)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname") - (getenv "MT_RUNNAME"))) + (get-environment-variable "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) (if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree (begin @@ -921,16 +921,16 @@ (set! toppath *toppath*) (if (not *toppath*) (begin (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (common:list-or-null (rmt:get-keys) message: "Failed to retrieve keys in launch.scm. Please report this to the developers.")) (key-vals (keys:target->keyval keys target)) - (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + (linktree (common:get-linktree)) ;; (or (get-environment-variable "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) ; (if *configdat* ; (configf:lookup *configdat* "setup" "linktree") ; (conc *toppath* "/lt")))) (second-pass (configf:find-and-read-config mtconfig @@ -938,11 +938,11 @@ given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME" env-to-use: (module-environment 'bigmod))) (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) + (set-environment-variable! (car kt) (cadr kt))) key-vals) (configf:read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... sections: sections))) (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) @@ -1018,12 +1018,12 @@ (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") ))) (if (and *toppath* (directory-exists? *toppath*)) (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (setenv "MT_TESTSUITENAME" (common:get-area-name))) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_TESTSUITENAME" (common:get-area-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") (set! *toppath* #f) ;; force it to be false so we return #f #f)) @@ -1299,21 +1299,21 @@ (define (launch:handle-zombie-tests run-id) (let* ((key (conc "zombiescan-runid-"run-id)) (now (current-seconds)) (threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120)))) - (val (rmt:get-var key)) + (val (rmt:get-var run-id key)) (do-scan? (cond ((not val) #t) ((< val threshold) #t) (else #f)))) (when do-scan? (debug:print 1 *default-log-port* "INFO: search and mark zombie tests") - (rmt:set-var key (current-seconds)) + (rmt:set-var run-id key (current-seconds)) (runs:find-and-mark-incomplete-and-check-end-of-run run-id #f)))) @@ -1888,29 +1888,29 @@ ;; 0 RUNNING ==> this is actually the first condition, should not get here (define (runs:end-of-run-check run-id ) (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id)) (running-cnt (rmt:get-count-tests-running-for-run-id run-id)) - (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id))) + (all-test-launched (rmt:get-var run-id (conc "lunch-complete-" run-id))) (current-state (rmt:get-run-state run-id)) (current-status (rmt:get-run-status run-id))) ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing (debug:print 0 *default-log-port* "Running test cnt :" running-cnt) (rmt:set-state-status-and-roll-up-run run-id current-state current-status) (runs:update-junit-test-reporter-xml run-id) (cond ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" )) - (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id))) + (if (and (equal? (rmt:get-var run-id (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id))) (begin - (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id))) + (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var run-id (conc "end-of-run-" run-id))) (debug:print 0 *default-log-port* "End of Run Detected.") (rmt:set-var (conc "end-of-run-" run-id) "yes") ;(thread-sleep! 10) (runs:run-post-hook run-id) - (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id))) + (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var run-id (conc "end-of-run-" run-id))) (common:simple-unlock (conc "endOfRun" run-id))) - (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id))))) + (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var run-id (conc "end-of-run-" run-id))))) ((> running-cnt 3) (debug:print 0 *default-log-port* "There are " running-cnt " tests running." )) ((> running-cnt 0) (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" ) (let ((kill-cnt (launch:kill-tests-if-dead run-id))) @@ -1968,11 +1968,11 @@ #f ;; get full data (not 'shortlist) 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time 'dashboard) '())) (log-dir (conc *toppath* "/logs")) - (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (log-file (conc "post-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log")) (full-log-fname (conc log-dir "/" log-file))) (if run-post-hook ;; (if (null? existing-tests) ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run."))))) (let* ((use-log-dir (if (not (directory-exists? log-dir)) @@ -1998,11 +1998,11 @@ (define (runs:rerun-hook test-id new-test-path testdat rerunlst) (let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook")) (log-dir (conc *toppath* "/reruns/logs")) - (target (getenv "MT_TARGET")) + (target (get-environment-variable "MT_TARGET")) (runname (common:args-get-runname)) (rundir (db:test-get-rundir testdat)) (tarfiledir (conc *toppath* "/reruns")) (status (db:test-get-status testdat)) (comment (conc "\"" (db:test-get-comment testdat) "\"" )) @@ -2053,14 +2053,14 @@ (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) (if junit-test-report-dir junit-test-report-dir - (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) + (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME"))) #f)) (xml-ts-name (if xml-dir - (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME")) + (conc (get-environment-variable "MT_TESTSUITENAME")"."(string-translate (get-environment-variable "MT_TARGET") "/" ".") "." (get-environment-variable "MT_RUNNAME")) #f)) (keyname (if xml-ts-name (common:get-signature xml-ts-name) #f)) (xml-path (if xml-dir (conc xml-dir "/" keyname ".xml") #f)) @@ -2141,11 +2141,11 @@ (testsuite))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) - (setenv (car item) (cadr item))) + (set-environment-variable! (car item) (cadr item))) itemdat)) ;; 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)) @@ -2155,16 +2155,16 @@ (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (common:get-fields *configdat*) #;(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"))) - (if testname (setenv "MT_TEST_NAME" testname)) - (if itempath (setenv "MT_ITEMPATH" itempath)) + (if testname (set-environment-variable! "MT_TEST_NAME" testname)) + (if itempath (set-environment-variable! "MT_ITEMPATH" itempath)) ;; get the info from the db and put it in the cache (if link-tree - (setenv "MT_LINKTREE" link-tree) + (set-environment-variable! "MT_LINKTREE" link-tree) (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) @@ -2180,11 +2180,11 @@ (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)) + (if (not (get-environment-variable "MT_TARGET"))(set-environment-variable! "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 @@ -2217,22 +2217,22 @@ (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) + (set-environment-variable! "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "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)) + (if testname (set-environment-variable! "MT_TEST_NAME" testname)) + (if itempath (set-environment-variable! "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") + (set-environment-variable! "MT_TEST_RUN_DIR" (conc (get-environment-variable "MT_LINKTREE") "/" + (get-environment-variable "MT_TARGET") "/" + (get-environment-variable "MT_RUNNAME") "/" + (get-environment-variable "MT_TEST_NAME") (if (and itempath (not (equal? itempath ""))) (conc "/" itempath) "")))))) @@ -2244,12 +2244,12 @@ ;; (if (eq? *configstatus* 'fulldata) ;; *runconfigdat* ;; (begin ;; (launch:setup) ;; *runconfigdat*))) - (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) - (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) + (let* ((rundir (if (and (get-environment-variable "MT_LINKTREE")(get-environment-variable "MT_TARGET")(get-environment-variable "MT_RUNNAME")) + (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME")) #f)) (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf (file-exists? cfgf) (file-writable? cfgf) @@ -2258,14 +2258,14 @@ (let* ((keys (common:get-fields *configdat*)) ;; (rmt:get-keys)) (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) (if key-vals (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) + (set-environment-variable! (car kt) (cadr kt))) key-vals)) ;; (configf: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) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -187,15 +187,15 @@ ;;====================================================================== ;; Test commands (i.e. for use inside tests) ;;====================================================================== (define (megatest:step step state status logfile msg) - (if (not (getenv "MT_CMDINFO")) + (if (not (get-environment-variable "MT_CMDINFO")) (begin (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) - (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (let* ((cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) @@ -324,19 +324,19 @@ (exit 1)))) (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (args:get-arg "-debug-noprop") - (getenv "MT_DEBUG_MODE")))) + (get-environment-variable "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr 'q)) (debug:check-verbosity *verbosity* debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not *verbosity*)(set! *verbosity* 1)) (if (and (not (args:get-arg "-debug-noprop")) (or (args:get-arg "-debug") - (not (getenv "MT_DEBUG_MODE")))) - (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) + (not (get-environment-variable "MT_DEBUG_MODE")))) + (set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) @@ -773,20 +773,20 @@ ;; before doing anything else change to the start-dir if provided ;; (if (args:get-arg "-start-dir") (if (common:file-exists? (args:get-arg "-start-dir")) (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) + (set-environment-variable! "PWD" fullpath) (change-directory fullpath)) (begin (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) - (if targ (setenv "MT_TARGET" targ))) + (if targ (set-environment-variable! "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; ;; (init-watchdog) @@ -924,11 +924,11 @@ ;; TODO: Restore this functionality #; (if (and (args:get-arg "-cache-db") (args:get-arg "-source-db")) - (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) + (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_"))))) (target-db (conc temp-dir "/cached.db")) (source-db (args:get-arg "-source-db"))) (db:cache-for-read-only source-db target-db) (set! *didsomething* #t))) @@ -1264,12 +1264,12 @@ (set! *didsomething* #t) (pop-directory) (bdat-time-to-exit-set! *bdat* #t))) (if (args:get-arg "-show-cmdinfo") - (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) - (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) + (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")) + (let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t)) (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) @@ -2060,13 +2060,13 @@ ;; Get paths to tests ;;====================================================================== ;; Get test paths matching target, runname, and testpatt (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;; if we are in a test use the MT_CMDINFO data - (if (getenv "MT_CMDINFO") + (if (get-environment-variable "MT_CMDINFO") (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) @@ -2227,16 +2227,16 @@ (args:get-arg "-test-status") (args:get-arg "-set-values") (args:get-arg "-load-test-data") (args:get-arg "-runstep") (args:get-arg "-summarize-items")) - (if (not (getenv "MT_CMDINFO")) + (if (not (get-environment-variable "MT_CMDINFO")) (begin (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) @@ -2453,11 +2453,11 @@ (args:get-arg "-diff-html") (args:get-arg "-diff-email")) (set! *didsomething* #t) (exit 0))) - (if (or (getenv "MT_RUNSCRIPT") + (if (or (get-environment-variable "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup))) ;; (dbstruct (if (and toppath @@ -2464,11 +2464,11 @@ ;; #;(common:on-homehost?)) ;; (db:setup #f) ;; sets up main.db ;; #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if *toppath* (cond - ((getenv "MT_RUNSCRIPT") + ((get-environment-variable "MT_RUNSCRIPT") ;; How to run megatest scripts ;; ;; #!/bin/bash ;; ;; export MT_RUNSCRIPT=yes Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -299,22 +299,23 @@ ;;====================================================================== ;; FOR DEBUGGING SET TO #t (define *localmode* #t) +(define *dbstruct* (make-dbr:dbstruct)) ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (if *localmode* - (let* ((dbstruct (db:cache-get-dbstruct rid apath)) + (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname)) (indat `((cmd . ,cmd)(params . ,params)))) - (api:process-request dbstruct indat)) + (api:process-request *dbstruct* indat)) (begin (rmt:general-open-connection conns apath dbname) (rmt:send-receive-real conns apath dbname cmd params))))) #;(define (rmt:send-receive-setup conn) @@ -760,27 +761,27 @@ ) ;; ) (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))) - -(define (rmt:inc-var varname) - (rmt:send-receive 'inc-var #f (list varname))) - -(define (rmt:dec-var varname) - (rmt:send-receive 'dec-var #f (list varname))) - -(define (rmt:add-var varname value) - (rmt:send-receive 'add-var #f (list varname value))) +(define (rmt:get-var run-id varname) + (rmt:send-receive 'get-var run-id (list run-id varname))) + +(define (rmt:del-var run-id varname) + (rmt:send-receive 'del-var run-id (list run-id varname))) + +(define (rmt:set-var run-id varname value) + (rmt:send-receive 'set-var run-id (list run-id varname value))) + +(define (rmt:inc-var run-id varname) + (rmt:send-receive 'inc-var #f (list run-id varname))) + +(define (rmt:dec-var run-id varname) + (rmt:send-receive 'dec-var run-id (list run-id varname))) + +(define (rmt:add-var run-id varname value) + (rmt:send-receive 'add-var run-id (list run-id varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== @@ -1418,18 +1419,18 @@ ;;====================================================================== ;; from metadat lookup MEGATEST_VERSION ;; (define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB - (rmt:get-var "MEGATEST_VERSION")) + (rmt:get-var #f "MEGATEST_VERSION")) (define (common:get-last-run-version-number) (string->number (substring (common:get-last-run-version) 0 6))) (define (common:set-last-run-version) - (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) + (rmt:set-var #f "MEGATEST_VERSION" (common:version-signature))) ;;====================================================================== ;; faux-lock is deprecated. Please use simple-lock below ;; (define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -298,11 +298,11 @@ #f ;; get full data (not 'shortlist) 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time 'dashboard) '())) (log-dir (conc *toppath* "/logs")) - (log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (log-file (conc "pre-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log")) (full-log-fname (conc log-dir "/" log-file))) (if run-pre-hook (if (null? existing-tests) (let* ((use-log-dir (if (not (directory-exists? log-dir)) (handle-exceptions @@ -498,19 +498,19 @@ ;; run the run prehook if there are no tests yet run for this run: ;; (runs:run-pre-hook run-id) ;; mark all test launched flag as false in the meta table - (rmt:set-var (conc "lunch-complete-" run-id) "no") + (rmt:set-var run-id (conc "lunch-complete-" run-id) "no") (debug:print-info 1 *default-log-port* "Setting end-of-run to no") (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) (config-rerun-cnt (if config-reruns config-reruns 1))) (if (eq? config-rerun-cnt run-count) - (rmt:set-var (conc "end-of-run-" run-id) "no"))) + (rmt:set-var run-id (conc "end-of-run-" run-id) "no"))) (rmt:set-run-state-status run-id "new" "n/a") ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data @@ -522,11 +522,11 @@ (if (not (null? test-names)) ;; BEGIN test-names loop (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. - (setenv "MT_TEST_NAME" hed) ;; + (set-environment-variable! "MT_TEST_NAME" hed) ;; (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry)) ;; NOTE: Have the config - can extract [waitons] section ((hed-mode) @@ -813,12 +813,12 @@ (and (member 'toplevel testmode) (null? non-completed))) (debug:print-info 4 *default-log-port* "cond branch - " "ei-2") (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) + (set-environment-variable! "MT_TEST_NAME" test-name) ;; + (set-environment-variable! "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) @@ -1705,11 +1705,11 @@ (else (debug:print-info 4 *default-log-port* "cond branch - " "rtq-9") (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; end loop on sorted test names ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched - (rmt:set-var (conc "lunch-complete-" run-id) "yes") + (rmt:set-var run-id (conc "lunch-complete-" run-id) "yes") ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle @@ -1827,13 +1827,13 @@ "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) - ;; (setenv "MT_TEST_NAME" test-name) ;; - ;; (setenv "MT_ITEMPATH" item-path) - ;; (setenv "MT_RUNNAME" runname) + ;; (set-environment-variable! "MT_TEST_NAME" test-name) ;; + ;; (set-environment-variable! "MT_ITEMPATH" item-path) + ;; (set-environment-variable! "MT_RUNNAME" runname) (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; @@ -2740,17 +2740,17 @@ (process-signal pid signal/int) (thread-sleep! 5) (if (process:alive? pid) (process-signal pid signal/kill))))) ;; (call-with-environment-variables - (let ((old-targethost (getenv "TARGETHOST"))) - (setenv "TARGETHOST" hostname) - (setenv "TARGETHOST_LOGF" "server-kills.log") + (let ((old-targethost (get-environment-variable "TARGETHOST"))) + (set-environment-variable! "TARGETHOST" hostname) + (set-environment-variable! "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) - (if old-targethost (setenv "TARGETHOST" old-targethost)) - (unsetenv "TARGETHOST") - (unsetenv "TARGETHOST_LOGF")))) + (if old-targethost (set-environment-variable! "TARGETHOST" old-targethost)) + (unset-environment-variable! "TARGETHOST") + (unset-environment-variable! "TARGETHOST_LOGF")))) (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) records))) (define (task:get-run-times) (let* ( Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -411,11 +411,11 @@ ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. (rmt:csv->test-data run-id test-id dat) ;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start" ;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue. - (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :) + ;; (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :) ;; BB - commentiong out arbitrary 10 second wait (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server. ))) ;; need to update the top test record if PASS or FAIL and this is a subtest ;;;;;; (if (not (equal? item-path "")) @@ -996,22 +996,22 @@ ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-test-path-from-environment) - (if (and (getenv "MT_LINKTREE") - (getenv "MT_TARGET") - (getenv "MT_RUNNAME") - (getenv "MT_TEST_NAME") - (getenv "MT_ITEMPATH")) - (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") - (if (and (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")) + (if (and (get-environment-variable "MT_LINKTREE") + (get-environment-variable "MT_TARGET") + (get-environment-variable "MT_RUNNAME") + (get-environment-variable "MT_TEST_NAME") + (get-environment-variable "MT_ITEMPATH")) + (conc (get-environment-variable "MT_LINKTREE") "/" + (get-environment-variable "MT_TARGET") "/" + (get-environment-variable "MT_RUNNAME") "/" + (get-environment-variable "MT_TEST_NAME") + (if (and (get-environment-variable "MT_ITEMPATH") + (not (string=? "" (get-environment-variable "MT_ITEMPATH")))) + (conc "/" (get-environment-variable "MT_ITEMPATH")) "")) #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" @@ -1046,13 +1046,13 @@ dat ;; no cached data available (let* ((treg (or test-registry (tests:get-all))) (test-path (or (hash-table-ref/default treg test-name #f) - (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" + (let* ((local-tcdir (conc (get-environment-variable "MT_LINKTREE") "/" + (get-environment-variable "MT_TARGET") "/" + (get-environment-variable "MT_RUNNAME") "/" test-name "/" item-path)) (local-tcfg (conc local-tcdir "/testconfig"))) (if (common:file-exists? local-tcfg) local-tcdir #f))