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: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -26,11 +26,11 @@ (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)) - (let ((pgconf (configf:lookup configdat "ext-sync" (or dbname "pgdb")))) + (let ((pgconf (or (configf:lookup configdat "ext-sync" (or dbname "pgdb")) (args:get-arg "-pgsync")))) (if pgconf (let* ((confdat (map (lambda (conf-item) (let ((parts (string-split conf-item ":"))) (if (> (length parts) 1) (let ((key (car parts)) 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")))) @@ -1010,22 +1019,34 @@ (else (let* ((currhost (get-host-name)) (bestadrs (server:get-best-guess-address currhost)) ;; first look in config, then look in file .homehost, create it if not found (homehost (or (configf:lookup *configdat* "server" "homehost" ) - (let ((hhf (conc *toppath* "/.homehost"))) - (if (file-exists? hhf) - (with-input-from-file hhf read-line) - (if (file-write-access? *toppath*) - (begin - (with-output-to-file hhf - (lambda () - (print bestadrs))) - (begin - (mutex-unlock! *homehost-mutex*) - (car (common:get-homehost)))) - #f))))) + (handle-exceptions + exn + (if (> trynum 0) + (let ((delay-time (* (- 5 trynum) 5))) + (mutex-unlock! *homehost-mutex*) + (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file, delaying " delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! delay-time) + (common:get-homehost trynum: (- trynum 1))) + (begin + (mutex-unlock! *homehost-mutex*) + (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) + (exit 1))) + (let ((hhf (conc *toppath* "/.homehost"))) + (if (file-exists? hhf) + (with-input-from-file hhf read-line) + (if (file-write-access? *toppath*) + (begin + (with-output-to-file hhf + (lambda () + (print bestadrs))) + (begin + (mutex-unlock! *homehost-mutex*) + (car (common:get-homehost)))) + #f)))))) (at-home (or (equal? homehost currhost) (equal? homehost bestadrs)))) (set! *home-host* (cons homehost at-home)) (mutex-unlock! *homehost-mutex*) *home-host*)))) @@ -1611,11 +1632,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 @@ -12,11 +12,11 @@ ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) -(use typed-records pathname-expand) +(use typed-records pathname-expand matchable) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) @@ -413,13 +413,15 @@ (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + ;; (transport (assoc/default 'transport cmdinfo)) ;; not used ;; (serverinf (assoc/default 'serverinf cmdinfo)) - (port (assoc/default 'port cmdinfo)) + ;; (port (assoc/default 'port cmdinfo)) + (serverurl (assoc/default 'serverurl cmdinfo)) + (homehost (assoc/default 'homehost cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (target (assoc/default 'target cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) @@ -443,10 +445,51 @@ runscript))))) ;; assume it is on the path ) ;; (rollup-status 0) (if contour (setenv "MT_CONTOUR" contour)) + ;; On NFS it can be slow and unreliable to get needed startup information. + ;; i. Check if we are on the homehost, if so, proceed + ;; ii. Check if host and port passed in via CMDINFO are valid and if + ;; possible use them. + (let ((bestadrs (server:get-best-guess-address (get-host-name))) + (needcare #f)) + (if (equal? homehost bestadrs) ;; we are likely on the homehost + (debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost) + (let ((host-port (if serverurl (string-split serverurl ":") #f))) + (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote* + (if (string? homehost) + (if (and host-port + (> (length host-port) 1)) + (let* ((host (car host-port)) + (port (cadr host-port)) + (start-res (http-transport:client-connect host port)) + (ping-res (rmt:login-no-auto-client-setup start-res))) + (if (and start-res + ping-res) + (let ((url (http-transport:server-dat-make-url start-res))) + (remote-conndat-set! *runremote* start-res) + (remote-server-url-set! *runremote* url) + (debug:print-info 0 *default-log-port* "connected to " url " using CMDINFO data.")) + (debug:print-info 0 *default-log-port* "received " host ":" port " for url but could not connect.") + )) + (begin + (debug:print-info 0 *default-log-port* (if host-port + (conc "received invalid host-port information " host-port) + "no host-port information received")) + ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare. + (set! needcare #t))) + (begin + (debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.") + (set! needcare #t))))) + (if needcare ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host + (let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory + (handle-exceptions + exn + (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn)) + (create-directory logdir #t))))) + ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) (change-directory top-path) @@ -576,11 +619,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 +725,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 +785,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 +843,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 +886,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 +962,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 +977,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 +1135,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") @@ -1185,12 +1232,19 @@ (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) - (list 'transport (conc *transport-type*)) + ;; (list 'transport (conc *transport-type*)) ;; (list 'serverinf *server-info*) + (list 'homehost (let* ((hhdat (common:get-homehost))) + (if hhdat + (car hhdat) + #f))) + (list 'serverurl (if *runremote* + (remote-server-url *runremote*) + #f)) ;; (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -288,10 +288,12 @@ "-src-target" "-src-runname" "-diff-email" "-sync-to" + "-prefix-target" + "-pgsync" "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" @@ -526,11 +528,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: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -36,15 +36,15 @@ (define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. (let* ((runremote (or area-dat *runremote*)) (cinfo (if (remote? runremote) (remote-conndat runremote) #f))) - (if cinfo - cinfo - (if (server:check-if-running areapath) - (client:setup areapath) - #f)))) + (if cinfo + cinfo + (if (server:check-if-running areapath) + (client:setup areapath) + #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; 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)) @@ -616,11 +616,11 @@ (runinf (hash-table-ref/default runs-ht run-id #f))) (if runinf runinf ;; already cached (let* ((keytarg (string-intersperse (rmt:get-keys) "/")) ;; e.g. version/iteration/platform (spec-id (pgdb:get-ttype dbh keytarg)) - (target (rmt:get-target run-id)) ;; e.g. v1.63/a3e1/ubuntu + (target (if (and (args:get-arg "-sync-to") (args:get-arg "-prefix-target")) (set! target (conc (args:get-arg "-prefix-target") (rmt:get-target run-id))) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu (run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > (run-name (rmt:get-run-name-from-id run-id)) (new-run-id (pgdb:get-run-id dbh spec-id target run-name)) (row (db:get-rows run-dat)) ;; yes, this returns a single row (header (db:get-header run-dat))