Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -111,11 +111,11 @@
(archive-id (if archive-info (car archive-info) -1))
(disk-groups (make-hash-table))
(test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
(bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(compress (or (configf:lookup *configdat* "archive" "compress") "9"))
- (linktree (configf:lookup *configdat* "setup" "linktree")))
+ (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
(if (not archive-dir) ;; no archive disk found, this is fatal
(begin
(debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config")
(debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space")
@@ -211,11 +211,11 @@
(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can
;; allocate as needed should a disk fill up
;;
(let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (linktree (configf:lookup *configdat* "setup" "linktree")))
+ (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
;; from the test info bin the path to the test by stem
;;
(for-each
(lambda (test-dat)
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -17,10 +17,11 @@
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
+(declare (uses keys))
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
@@ -32,16 +33,19 @@
;; (old-exit)
;; (old-exit code)))
(define getenv get-environment-variable)
(define (safe-setenv key val)
- (if (and (string? val)(string? key))
- (handle-exceptions
- exn
- (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
- (setenv key val))
- (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))
+ (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
+ (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
+ (if (and (string? val)
+ (string? key))
+ (handle-exceptions
+ exn
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
+ (setenv key val))
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
@@ -952,12 +956,17 @@
rtestpatt)
(else args-testpatt))))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
- (if *configdat*
- (configf:lookup *configdat* "setup" "linktree"))))
+ (or (and *configdat*
+ (configf:lookup *configdat* "setup" "linktree"))
+ (if *toppath*
+ (conc *toppath* "/lt")
+ (if (file-exists? "megatest.config") ;; we are in the toppath (new area, mtutils compatible)
+ (conc (current-directory) "/lt")
+ #f)))))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
@@ -1611,11 +1620,12 @@
(let* ((key (car keyval))
(val (cdr keyval))
(delim (if (string-search whitesp val)
"\""
"")))
- (print (if (member key ignorevars)
+ (print (if (or (member key ignorevars)
+ (string-search ":" key)) ;; internal only values to be skipped.
"# export "
"export ")
key "=" delim (mungeval val) delim)))
envvars)))))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -15,10 +15,11 @@
(use regex regex-case) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
+(declare (uses keys))
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -57,11 +57,11 @@
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (portlogger:open-run-close portlogger:find-port))
- (link-tree-path (configf:lookup *configdat* "setup" "linktree")))
+ (link-tree-path (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
(debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
(handle-directory spiffy-directory-listing)
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -576,11 +576,11 @@
(list "MT_ITEM_INFO" (conc itemdat))
(list "MT_ITEMPATH" item-path)
(list "MT_RUNNAME" runname)
(list "MT_MEGATEST" megatest)
(list "MT_TARGET" target)
- (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree"))
+ (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(list "MT_TESTSUITENAME" (common:get-testsuite-name))))
(if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
;; (change-directory top-path)
;; Can setup as client for server mode now
@@ -682,11 +682,11 @@
;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
(if (and *configdat*
(or (args:get-arg "-run")
(args:get-arg "-runtests")
(args:get-arg "-execute")))
- (let* ((linktree (get-environment-variable "MT_LINKTREE"))
+ (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")))
(fulldir (conc linktree "/"
@@ -742,11 +742,11 @@
(define (launch:setup-body #!key (force #f) (areapath #f))
(let* ((toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
(runname (common:args-get-runname))
(target (common:args-get-target exit-if-bad: #t))
(linktree (common:get-linktree))
- (contour (args:get-arg "-contour"))
+ (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour"))
(sections (if target (list "default" target) #f)) ;; for runconfigs
(mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
(rundir (if (and runname target linktree)(conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) #f))
(mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
(rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
@@ -800,12 +800,15 @@
(exit 1)))
(setenv "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 (rmt:get-keys))
(key-vals (keys:target->keyval keys target))
- (linktree (or (getenv "MT_LINKTREE")
- (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (linktree (common:get-linktree))
+ ; (or (getenv "MT_LINKTREE")
+ ; (if *configdat*
+ ; (configf:lookup *configdat* "setup" "linktree")
+ ; (conc *toppath* "/lt"))))
(second-pass (find-and-read-config
mtconfig
environ-patt: "env-override"
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
@@ -840,12 +843,11 @@
(set! *configstatus* 'partial))
(begin
(debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
(exit 2))))))
;; additional house keeping
- (let* ((linktree (or (getenv "MT_LINKTREE")
- (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))))
+ (let* ((linktree (common:get-linktree)))
(if linktree
(begin
(if (not (file-exists? linktree))
(begin
(handle-exceptions
@@ -917,11 +919,11 @@
(runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name.
run-info
(db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info)
"runname")))
- (contour (args:get-arg "-contour"))
+ (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour"))
;; convert back to db: from rdb: - this is always run at server end
(target (string-intersperse (map cadr keyvals) "/"))
(not-iterated (equal? "" item-path))
@@ -932,12 +934,14 @@
;; nb// if itempath is not "" then it is prefixed with "/"
(toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base))
(test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base))
;; ensure this exists first as links to subtests must be created there
- (linktree (let ((rd (config-lookup *configdat* "setup" "linktree")))
- (if rd rd (conc *toppath* "/runs"))))
+ (linktree (common:get-linktree))
+ ;; WAS: (let ((rd (config-lookup *configdat* "setup" "linktree")))
+ ;; (if rd rd (conc *toppath* "/runs"))))
+ ;; which seems wrong ...
(lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))
(lnktarget (conc lnkpath "/" item-path)))
@@ -1088,11 +1092,11 @@
;; - could be netbatch
;; (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
(mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex
(let* ((item-path (item-list->path itemdat))
- (contour (args:get-arg "-contour")))
+ (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour")))
(let loop ((delta (- (current-seconds) *last-launch*))
(launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5"))))
(if (> launch-delay delta)
(begin
(debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds")
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -526,11 +526,11 @@
(begin
(set! *didsomething* #t) ;; suppress the help output.
(if (getenv "MT_TARGET") ;; no point in trying if no target
(if (args:get-arg "-runname")
(let* ((toppath (launch:setup))
- (linktree (if toppath (configf:lookup *configdat* "setup" "linktree")))
+ (linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree")))
(runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname")))
(files (if (file-exists? runtop)
(append (glob (conc runtop "/.megatest*"))
(glob (conc runtop "/.runconfig*")))
'())))
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -208,11 +208,11 @@
(tal (cdr test-dirs)))
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (file-exists? tconfig-file)
(file-read-access? tconfig-file))
- (let ((link-tree-path (configf:lookup *configdat* "setup" "linktree"))
+ (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -12,11 +12,11 @@
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
- srfi-18 extras format pkts regex regex-case
+ srfi-18 extras format pkts pkts regex regex-case
(prefix dbi dbi:)) ;; zmq extras)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
@@ -343,11 +343,11 @@
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
- (apkt (convert-pkt->alist pktdat))
+ (apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
(debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
@@ -354,11 +354,11 @@
pkts))))
(string-split pktsdirs)))))
(define (get-pkt-alists pkts)
(map (lambda (x)
- (alist-ref 'pkta x)) ;; 'pkta pulls out the alist from the read pkt
+ (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
pkts))
;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
(define (get-pkt-times pkts)
@@ -762,11 +762,11 @@
(val (cdr a))
(par (lookup-param-by-key key)))
;; (print "key: " key " val: " val " par: " par)
(if par
(conc res " " (param-translate par) " " val)
- (if (member key '(a Z U D)) ;; a is the action
+ (if (member key '(a Z U D T)) ;; a is the action
res
(begin
(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
res)))))
(conc "megatest " (if (not (member action '("sync")))
@@ -808,11 +808,11 @@
(pkts (find-pkts pdb '(cmd) '()))
(torun (make-hash-table)) ;; target => ( ... info ... )
(rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
(for-each
(lambda (pktdat)
- (let* ((pkta (alist-ref 'pkta pktdat))
+ (let* ((pkta (alist-ref 'apkt pktdat))
(action (alist-ref 'a pkta))
(cmdline (pkt->cmdline pkta))
(uuid (alist-ref 'Z pkta))
(logf (conc logdir "/" uuid "-run.log"))
(fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
Index: runconfigs.config
==================================================================
--- runconfigs.config
+++ runconfigs.config
@@ -1,5 +1,12 @@
+# To get emacs font highlighing in the various megatest configs do this:
+#
+# Install emacs-goodies-el:
+# sudo apt install emacs-goodies-el
+# Add to your ~/.emacs file:
+# (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
+#
# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -21,10 +21,11 @@
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
+(declare (uses keys))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
@@ -56,11 +57,11 @@
(common:args-get-target)
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
- (link-tree (configf:lookup *configdat* "setup" "linktree")))
+ (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
(if testname (setenv "MT_TEST_NAME" testname))
(if itempath (setenv "MT_ITEMPATH" itempath))
;; get the info from the db and put it in the cache
(if link-tree
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -60,11 +60,11 @@
#t))))))
(define (tasks:get-task-db-path)
(let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir")
(configf:lookup *configdat* "setup" "dbdir")
- (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))))
+ (conc (common:get-linktree) "/.db"))))
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))