Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -8,11 +8,11 @@ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm nmsg-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm rpc-transport.scm \ - portlogger.scm archive.scm + portlogger.scm archive.scm env.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ ADDED env.scm Index: env.scm ================================================================== --- /dev/null +++ env.scm @@ -0,0 +1,105 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(declare (unit env)) + +(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 nanomsg srfi-18 call-with-environment-variables) + +(define (env:open-db fname) + (let* ((db-exists (file-exists? fname)) + (db (open-database fname))) + (if (not db-exists) + (begin + (exec (sql db "CREATE TABLE envvars ( + id INTEGER PRIMARY KEY, + context TEXT NOT NULL, + var TEXT NOT NULL, + val TEXT NOT NULL, + CONSTRAINT envvars_constraint UNIQUE (context,var))")))) + (set-busy-handler! db (busy-timeout 10000)) + db)) + +;; save vars in given context, this is NOT incremental by default +;; +(define (env:save-env-vars db context #!key (incremental #f)) + (with-transaction + db + (lambda () + ;; first clear out any vars for this context + (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context)) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cdr varval))) + (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var)) + (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val))) + (get-environment-variables))))) + +;; apply contexts to current environment +;; - each context is applied in the given order +;; - variables in the paths list are split on the separator and the components +;; merged using simple delta addition +;; +(define (env:apply-contexts db basecontext contexts paths outputf formats) + + (for-each + (lambda (context) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (vala (cadr row)) + (valb (caddr row))) + ;;(print "var: " var " vala: " vala " valb" valb " paths: " paths) + (if (assoc var paths) ;; this var is a PATH + (let ((current (get-environment-variable var))) ;; use this NOT vala + ;;(pp paths) + ;;(pp var) + (env:process-path-envvar var (cadr (assoc var paths)) current valb)) + (begin + (setenv var valb)))))) + (sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=? AND a.val != b.val") + ;;(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=?") + basecontext context)) + contexts)) + +(define (env:blind-merge l1 l2) + (if (null? l1) l2 + (if (null? l2) l1 + (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2))))))) + +;; given a before and an after envvar calculate a new merged path +;; +(define (env:merge-path-envvar separator patha pathb) + (let* ((patha-parts (string-split patha separator)) + (pathb-parts (string-split pathb separator)) + (common-parts (lset-intersection equal? patha-parts pathb-parts)) + (final (delete-duplicates ;; env:blind-merge + (append pathb-parts common-parts patha-parts)))) +;; (print "BEFORE: " (string-intersperse patha-parts "\n ")) +;; (print "AFTER: " (string-intersperse pathb-parts "\n ")) +;; (print "COMMON: " (string-intersperse common-parts "\n ")) + (string-intersperse final separator))) + +(define (env:process-path-envvar varname separator patha pathb) + (begin + (print "Process-path-envvar: " varname) + ) + (let ((newpath (env:merge-path-envvar separator patha pathb))) + (setenv varname newpath))) + +(define (env:have-context db context) + (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) + 0)) + +;; this is so the calling block does not need to import sql-de-lite +(define (env:close-database db) + (close-database db)) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -41,10 +41,11 @@ (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. +(declare (uses env)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -156,10 +157,11 @@ -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... Utilities -env2file fname : write the environment to fname.csh and fname.sh + -envcap fname=context : save current variables labeled as context in file fname -refdb2dat refdb : convert refdb to sexp or to format specified by -dumpmode formats: perl, ruby, sqlite3, csv (for csv the -o param will substitute %s for the sheet name in generating multiple sheets) -o : output file for refdb2dat (defaults to stdout) @@ -230,10 +232,11 @@ "-kill-server" "-port" "-extract-ods" "-pathmod" "-env2file" + "-envcap" "-setvars" "-set-state-status" "-set-run-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" @@ -676,37 +679,37 @@ (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) (set! *didsomething* #t)) - (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) + (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))) ;; Not a server? This section will decide how to communicate ;; ;; Setup client for all expect listed here - (if (null? (lset-intersection - equal? - (hash-table-keys args:arg-hash) - '("-list-servers" - "-stop-server" - "-show-cmdinfo" - "-list-runs" - "-ping"))) - (if (launch:setup-for-run) - (let ((run-id (and (args:get-arg "-run-id") - (string->number (args:get-arg "-run-id"))))) - ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) - ;; if not list or kill then start a client (if appropriate) - (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") - (eq? (length (hash-table-keys args:arg-hash)) 0)) - (debug:print-info 1 "Server connection not needed") - (begin - ;; (if run-id - ;; (client:launch run-id) - ;; (client:launch 0) ;; without run-id we'll start a server for "0" - #t - )))))) + ;; (if (null? (lset-intersection + ;; equal? + ;; (hash-table-keys args:arg-hash) + ;; '("-list-servers" + ;; "-stop-server" + ;; "-show-cmdinfo" + ;; "-list-runs" + ;; "-ping"))) + ;; (if (launch:setup-for-run) + ;; (let ((run-id (and (args:get-arg "-run-id") + ;; (string->number (args:get-arg "-run-id"))))) + ;; ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) + ;; ;; if not list or kill then start a client (if appropriate) + ;; (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") + ;; (eq? (length (hash-table-keys args:arg-hash)) 0)) + ;; (debug:print-info 1 "Server connection not needed") + ;; (begin + ;; ;; (if run-id + ;; ;; (client:launch run-id) + ;; ;; (client:launch 0) ;; without run-id we'll start a server for "0" + ;; #t + ;; )))))) ;; MAY STILL NEED THIS ;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") @@ -1875,10 +1878,28 @@ (db:multi-db-sync #f ;; do all run-ids 'new2old ) (set! *didsomething* #t))) + +;;====================================================================== +;; Capture, save and manipulate environments +;;====================================================================== + +(let ((envcap (args:get-arg "-envcap"))) + (if envcap + (if (substring-index "=" envcap) + (let* ((parts (string-split envcap "=")) + (fname (car parts)) + (context (cadr parts)) + (db (env:open-db fname))) + (env:save-env-vars db context) + (env:close-database db) + (set! *didsomething* #t)) + (begin + (debug:print 0 "ERROR: Parameter to -envcap should be =. E.G. envdat=original, got: " envcap) + (set! *didsomething* #t))))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== Index: tests/fullrun/multi-dboard.sh ================================================================== --- tests/fullrun/multi-dboard.sh +++ tests/fullrun/multi-dboard.sh @@ -1,20 +1,20 @@ #!/bin/bash if [[ ! -e "$HOME/.megatest" ]];then mkdir -p "$HOME/.megatest" fi -if [[ ! -e "$HOME/.megatest/areas.dat" ]];then - echo "Creating some placeholder files in ~/.megatest" - cat > "$HOME/.megatest/areas.dat" << EOF -[default] -mfstest /mfs/matt/data/megatest/tests/fullrun -mfsbig /mfs/matt/data/megatest/tests/fdktestqa/testqa -[local] -localtest /home/matt/data/megatest/tests/fullrun -EOF -fi +# if [[ ! -e "$HOME/.megatest/areas.dat" ]];then +# echo "Creating some placeholder files in ~/.megatest" +# cat > "$HOME/.megatest/areas.dat" << EOF +# [default] +# mfstest /mfs/matt/data/megatest/tests/fullrun +# mfsbig /mfs/matt/data/megatest/tests/fdktestqa/testqa +# [local] +# localtest /home/matt/data/megatest/tests/fullrun +# EOF +# fi if [[ ! -e "$HOME/.megatest/default.dat" ]];then cat > "$HOME/.megatest/default.dat" << EOF [fullrun] path /mfs/matt/data/megatest/tests/fullrun order 1