Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -234,10 +234,35 @@ ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks) (hash-table-ref/default (read-config "megatest.config" #f #t) "disks" '("none" ""))) + +;;====================================================================== +;; T A R G E T S +;;====================================================================== + +(define (common:args-get-target #!key (split #f)) + (let* ((target (if (args:get-arg "-reqtarg") + (args:get-arg "-reqtarg") + (if (args:get-arg "-target") + (args:get-arg "-target") + #f))) + (tlist (if target (string-split target "/" #t) '())) + (valid (if target + (and (not (null? tlist)) + (null? (filter string-null? tlist))) + #f))) + (if valid + (if split + tlist + target) + (if target + (begin + (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed") + #f) + #f)))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== @@ -360,28 +385,32 @@ (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) -(define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR"))) +(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR"))) (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (key) - (if (not (member key ignorevars)) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "setenv " (car key) " " sval)))) + (let* ((val (cdr key)) + (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) + (print (if (member key ignorevars) + "# setenv " + "setenv ") + (car key) " " sval))) envvars))) (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (key) - (if (not (member key ignorevars)) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "export " (car key) "=" sval)))) + (let* ((val (cdr key)) + (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) + (print (if (member key ignorevars) + "# export " + "export ") + (car key) "=" sval))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -457,15 +457,11 @@ targets) (set! *didsomething* #t))) (define (full-runconfigs-read) (let* ((keys (rmt:get-keys)) - (target (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - #f))) + (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*) (if key-vals @@ -521,12 +517,11 @@ ;; since several actions can be specified on the command line the removal ;; is done first (define (operate-on action) (let* ((runrec (runs:runrec-make-record)) - (target (or (args:get-arg "-reqtarg") - (args:get-arg "-target")))) + (target (common:args-get-target))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") (exit 1)) ((not (args:get-arg ":runname")) @@ -568,12 +563,13 @@ (args:get-arg "-get-run-status")) (general-run-call "-set-run-status" "set run status" (lambda (target runname keys keyvals) - (let* ((runsdat (cdb:remote-run db:get-runs-by-patt #f keys runname (or (args:get-arg "-target") - (args:get-arg "-reqtarg")) #f #f)) + (let* ((runsdat (cdb:remote-run db:get-runs-by-patt #f keys runname + (common:args-get-target) + #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) (begin (debug:print-info 0 "No matching run found.") @@ -599,12 +595,12 @@ (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (keys (db:get-keys dbstruct)) ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) - (runsdat (db:get-runs-by-patt dbstruct keys runpatt (or (args:get-arg "-target") - (args:get-arg "-reqtarg")) #f #f)) + (runsdat (db:get-runs-by-patt dbstruct keys runpatt (common:args-get-target) + #f #f)) ;; (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -11,12 +11,11 @@ (include "common_records.scm") (define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) (let* ((keys (map car keyvals)) (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") - (or (args:get-arg "-reqtarg") - (args:get-arg "-target") + (or (common:args-get-target) (get-environment-variable "MT_TARGET") (begin (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? @@ -60,12 +59,11 @@ finaldat)) (define (set-run-config-vars run-id keyvals targ-from-db) (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... (let ((runconfigf (conc *toppath* "/runconfigs.config")) - (targ (or (args:get-arg "-target") - (args:get-arg "-reqtarg") + (targ (or (common:args-get-target) targ-from-db (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id #t keyvals Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -43,12 +43,11 @@ *configdat* (begin (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") (exit 1))))) (runrec (runs:runrec-make-record)) - (target (or (args:get-arg "-reqtarg") - (args:get-arg "-target"))) + (target (common:args-get-target)) (runname (or (args:get-arg ":runname") (args:get-arg "-runname"))) (testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests"))) (keys (keys:config-get-fields mconfig)) @@ -90,12 +89,11 @@ (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) (define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) - (let* ((target (or (args:get-arg "-reqtarg") - (args:get-arg "-target") + (let* ((target (or (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))) ;; get the info from the db and put it in the cache @@ -1390,26 +1388,21 @@ ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) (let ((runname (args:get-arg ":runname")) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - (args:get-arg "-reqtarg")))) - ;; (th1 #f)) + (target (common:args-get-target))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") (exit 3)) (else (let ((db #f) - (keys #f) - (target (or (args:get-arg "-reqtarg") - (args:get-arg "-target")))) + (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; (if (args:get-arg "-server")