Index: archive-inc.scm
==================================================================
--- archive-inc.scm
+++ archive-inc.scm
@@ -16,367 +16,5 @@
;; along with Megatest. If not, see .
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-;;======================================================================
-;;
-;;======================================================================
-
-;; NOT CURRENTLY USED - commented out as it has unresolved dependencies
-;;
-#;(define (archive:main linktree target runname testname itempath options)
- (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
- (flavor 'plain) ;; type of machine to run jobs on
- (maxload 1.5) ;; max allowed load for this work
- (adisks (archive:get-archive-disks)))
- ;; get testdir size
- ;; - hand off du to job mgr
- (if (and (common:file-exists? testdir)
- (file-is-writable? testdir))
- (let* ((dused (jobrunner:run-job
- flavor ;; machine type
- maxload ;; max allowed load
- '() ;; prevars - environment vars to set for the job
- common:get-disk-space-used ;; if a proc call it, if a string it is a unix command
- (list testdir)))
- (apath (archive:get-archive testname itempath dused)))
- (jobrunner:run-job
- flavor
- maxload
- '()
- archive:run-bup
- (list testdir apath))))))
-
-;; Get archive disks from megatest.config
-;;
-(define (archive:get-archive-disks)
- (let ((section (configf:get-section *configdat* "archive-disks")))
- (if section
- section
- '())))
-
-;; look for the best candidate archive area, else create new
-;; area
-;;
-(define (archive:get-archive testname itempath dused)
- ;; look up in archive_allocations if there is a pre-used archive
- ;; with adequate diskspace
- ;;
- (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
- (candidate-disks (map (lambda (block)
- (list
- (vector-ref block 1) ;; archive-area-name
- (vector-ref block 2))) ;; disk-path
- existing-blocks)))
- (or (common:get-disk-with-most-free-space candidate-disks dused)
- (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath))))
-
-;; allocate a new archive area
-;;
-(define (archive:allocate-new-archive-block blockid-cache run-area-home testsuite-name dneeded target run-name test-name)
- (let ((key (conc testsuite-name "/" target "/" run-name "/" test-name)))
- (if (hash-table-exists? blockid-cache key)
- (hash-table-ref blockid-cache key)
- (let* ((pscript (configf:lookup *configdat* "archive" "pathscript"))
- (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
- (apath (if pscript
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: script \"" pscript-cmd "\" failed to run properly.")
- (exit 1))
- (with-input-from-pipe
- pscript-cmd
- read-line))
- #f)) ;; this is the user-calculated archive path
- (adisks (archive:get-archive-disks))
- (best-disk (common:get-disk-with-most-free-space adisks dneeded)))
- (if best-disk
- (let* ((bdisk-name (car best-disk))
- (bdisk-path (cdr best-disk))
- (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5))
- (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
- (archive-name (if apath
- apath
- (let ((sec (current-seconds)))
- (conc (time->string (seconds->local-time sec) "%Y")
- "_q" (seconds->quarter sec) "/"
- testsuite-name "_" area-key))))
- (archive-path (conc bdisk-path "/" archive-name))
- (block-id (rmt:archive-register-block-name bdisk-id archive-path)))
- ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
- (if block-id ;; (and block-id allocation-id)
- (let ((res (cons block-id archive-path)))
- (hash-table-set! blockid-cache key res)
- res)
- #f))
- #f)) ;; no best disk found
- )))
-
-;; archive - run bup
-;;
-;; 1. create the bup dir if not exists
-;; 2. start the du of each directory
-;; 3. gen index
-;; 4. save
-;;
-(define (archive:run-bup 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* ((blockid-cache (make-hash-table))
- (tsname (common:get-testsuite-name))
- (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
- (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area
- (disk-groups (make-hash-table)) ;;
- (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
- (test-dirs (make-hash-table))
- (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
- (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
- (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)))
- (print-prefix "Running: ") ;; change to #f to turn off printing
- (preclean-spec (configf:get-section *configdat* "archive-preclean")))
-
- ;; (tests:match patt testname itempath)
-
- ;; from the test info bin the path to the test by stem
- ;;
- (for-each
- (lambda (test-dat)
- (let* ((item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
- (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- (mutex-lock! rp-mutex)
- (test-physical-path (if (common:file-exists? test-path)
- (common:real-path test-path)
- #f))
- (mutex-unlock! rp-mutex)
- (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f))
- (test-base (if (and partial-path-index
- test-physical-path )
- (substring test-physical-path
- 0
- partial-path-index)
- #f))
- ;; we need our archive dir checked for every test to enable folks who want to store other ways.
- (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
- (archive-dir (if archive-info (cdr archive-info) #f))
- (archive-id (if archive-info (car archive-info) -1))
-
- )
-
- (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")
- (debug:print 0 *default-log-port* " disks: "
- (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
- (exit 1))
- (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path))
-
- ;; preclean the test directory per the spec if provided
- (if (not (null? preclean-spec)) ;; we've been asked to preclean before archiving
- (let loop ((spec (car preclean-spec))
- (tail (cdr preclean-spec)))
- (if (> (length spec) 1)
- (let ((testspec (car spec))
- (rules (cadr spec)))
- (if (tests:match testspec test-name item-path)
- (begin
- (debug:print 0 *default-log-port* "INFO: cleanup requested for " test-physical-path)
- (common:dir-clean-up test-physical-path rules remove-empty: #t))
- (if (not (null? tail))
- (loop (car tail)(cdr tail)))))
- (begin
- (debug:print 0 *default-log-port* "ERROR: bad spec line in [archive-preclean] section. \"" spec "\"")
- (if (not (null? tail))(loop (car tail)(cdr tail)))))))
- (cond
- (toplevel/children
- (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id
- " as it is a toplevel test with children"))
- ((not (common:file-exists? test-path))
- (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path
- " as path " test-path " does not exist"))
- (else
- (debug:print 0 *default-log-port*
- "From test-dat=" test-dat " derived the following:\n"
- "test-partial-path = " test-partial-path "\n"
- "test-path = " test-path "\n"
- "test-physical-path = " test-physical-path "\n"
- "partial-path-index = " partial-path-index "\n"
- "test-base = " test-base)
- (hash-table-set! disk-groups test-base
- (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
- (hash-table-set! test-groups test-base
- (cons test-dat (hash-table-ref/default test-groups test-base '())))
- (hash-table-set! arch-groups test-base
- (cons archive-info (hash-table-ref/default arch-groups test-base '())))
- (hash-table-set! test-dirs test-id test-path)))))
- ;; test-path))))
- tests)
- (debug:print 0 *default-log-port* "INFO: DISK GROUPS=" (hash-table->alist disk-groups))
- ;; for each disk-group, initialize the bup area if needed
- (for-each
- (lambda (test-base)
- (let* ((disk-group (hash-table-ref disk-groups test-base))
- (arch-group (hash-table-ref arch-groups test-base))
- (arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
- (archive-id (car arch-info))
- (archive-dir (cdr arch-info)))
- (debug:print 0 *default-log-port* "Processing disk-group " test-base)
- (let* ((test-paths (hash-table-ref disk-groups test-base)))
- (if (not (common:file-exists? archive-dir))
- (create-directory archive-dir #t))
- (case archiver
- ((bup) ;; Archive using bup
- (let* ((bup-init-params (list "-d" archive-dir "init"))
- (bup-index-params (append (list "-d" archive-dir "index") test-paths))
- (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
- (conc "-" compress) ;; or (conc "--compress=" compress)
- "-n" (conc (common:get-testsuite-name) "-" run-id)
- (conc "--strip-path=" test-base) ;; if we push to the directory do we need this?
- )
- test-paths)))
- (if (not (common:file-exists? (conc archive-dir "/HEAD")))
- (begin
- ;; replace this with jobrunner stuff enventually
- (debug:print-info 0 *default-log-port* "Init bup in " archive-dir)
- ;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)
- ;; (mutex-unlock! bup-mutex)
- ))
- (debug:print-info 0 *default-log-port* "Indexing data to be archived")
- ;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
- (debug:print-info 0 *default-log-port* "Archiving data with bup")
- (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
- ((7z tar)
- (for-each
- (lambda (test-dat)
- (let* ((test-id (db:test-get-id test-dat))
- (test-name (db:test-get-testname test-dat))
- (item-path (db:test-get-item-path test-dat))
- (test-full-name (db:test-make-full-name test-name item-path))
- (run-id (db:test-get-run_id test-dat))
- (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
- (run-name (rmt:get-run-name-from-id run-id))
- (source-dir (hash-table-ref test-dirs test-id)) ;; (conc test-base "/" test-name "/" item-path))
- (target-dir (string-substitute "/$" "" (conc archive-dir "/" target "/" run-name "/" test-full-name))))
- ;; create the test and item-path levels under archive-dir
- (create-directory (pathname-directory target-dir) #t)
- (run-n-wait
- (conc
- (string-substitute "ARCHIVE_NAME" target-dir archiver-cmd) " "
- "."
- )
- print-cmd: print-prefix
- run-dir: source-dir)))
- (hash-table-ref test-groups test-base))))
- ;; (mutex-unlock! bup-mutex)
- (for-each
- (lambda (test-dat)
- (let ((test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat)))
- (rmt:test-set-archive-block-id run-id test-id archive-id)
- (if (member archive-command '("save-remove"))
- (runs:remove-test-directory test-dat 'archive-remove))))
- (hash-table-ref test-groups test-base)))))
- (hash-table-keys disk-groups))
- #t))
-
-(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 (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)
- ;; When restoring test-dat will initially contain an old and invalid path to the test
- (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk.
- (item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
- (keyvals (rmt:get-key-val-pairs run-id))
- (target (string-intersperse (map cadr keyvals) "/"))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory
- (mutex-lock! rp-mutex)
- (prev-test-physical-path (if (common:file-exists? test-path)
- ;; (read-symbolic-link test-path #t)
- (common:real-path test-path)
- #f))
- (mutex-unlock! rp-mutex)
- (new-test-physical-path (conc best-disk "/" test-partial-path))
- (archive-block-id (db:test-get-archived test-dat))
- (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
- (archive-path (if (vector? archive-block-info)
- (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
- #f)) ;; no archive found?
- (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
-
- ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
- ;;
- (if (and (not toplevel/children) ;; special handling needed for toplevel with children
- prev-test-physical-path
- (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
- (let* ((base (pathname-directory prev-test-physical-path))
- (dirn (pathname-file prev-test-physical-path))
- (newn (conc base "/." dirn)))
- (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
- (rename-file prev-test-physical-path newn)))
-
- (if (and archive-path ;; no point in proceeding if there is no actual archive
- (not toplevel/children))
- (begin
- ;; CREATE WORK AREA
- ;; test-src-path == #f ==> don't copy in data from tests directory
- ;; itemdat == string ==> use directly
- (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
-
- ;; 1. Get the block id from the test info
- ;; 2. Get the block data given the block id
- ;; 3. Construct the paths etc. for the following command:
- ;;
- ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
-
- ;; DO BUP RESTORE
- (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
- (new-test-path (if (vector? new-test-dat )
- (db:test-get-rundir new-test-dat)
- (begin
- (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
- (exit 1))))
- ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
- (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
- (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
- ;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
- ;; (mutex-unlock! bup-mutex)
- (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
- (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
- (filter vector? tests))))
-
Index: runconfig-inc.scm
==================================================================
--- runconfig-inc.scm
+++ runconfig-inc.scm
@@ -13,189 +13,5 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
-;;======================================================================
-;; read a config file, loading only the section pertinent
-;; to this run field1val/field2val/field3val ...
-;;======================================================================
-
-(define (runconfig:read fname target environ-patt)
- (let ((ht (make-hash-table)))
- (if target (hash-table-set! ht target '()))
- (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
-
-;; NB// to process a runconfig ensure to use environ-patt with target!
-;;
-(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 (common:args-get-target)
- (get-environment-variable "MT_TARGET")
- (begin
- (debug:print-error 0 *default-log-port* "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?
- ;; NOTE: Should be setting env vars based on (target|default)
- (confdat (runconfig:read fname thekey environ-patt))
- (whatfound (make-hash-table))
- (finaldat (make-hash-table))
- (sections (list "default" thekey)))
- (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
- (debug:print 4 *default-log-port* "Using key=\"" thekey "\"")
-
- (if change-env
- (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
- (lambda (keyval)
- (safe-setenv (car keyval)(cadr keyval)))
- keyvals))
-
- (for-each
- (lambda (section)
- (let ((section-dat (hash-table-ref/default confdat section #f)))
- (if section-dat
- (for-each
- (lambda (envvar)
- (let ((val (cadr (assoc envvar section-dat))))
- (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
- (if (and (string? envvar)
- (string? val)
- change-env)
- (safe-setenv envvar val))
- (hash-table-set! finaldat envvar val)))
- (map car section-dat)))))
- sections)
- (if already-seen
- (begin
- (debug:print 2 *default-log-port* "Key settings found in runconfigs.config:")
- (for-each (lambda (fullkey)
- (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
- sections)
- (debug:print 2 *default-log-port* "---")
- (set! *already-seen-runconfig-info* #t)))
- ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses
- confdat
- ))
-
-(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 (common:args-get-target)
- targ-from-db
- (get-environment-variable "MT_TARGET"))))
- (pop-directory)
- (if (common:file-exists? runconfigf)
- (setup-env-defaults runconfigf run-id #t keyvals
- environ-patt: (conc "(default"
- (if targ
- (conc "|" targ ")")
- ")")))
- (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf))))
-
-;; given (a (b c) d) return ((a b d)(a c d))
-;; NOTE: this feels like it has been done before - perhaps with items handling?
-;;
-(define (runconfig:combinations inlst)
- (let loop ((hed (car inlst))
- (tal (cdr inlst))
- (res '()))
- ;; (print "res: " res " hed: " hed)
- (if (list? hed)
- (let ((newres (if (null? res) ;; first time through convert incoming items to list of items
- (map list hed)
- (apply append
- (map (lambda (r) ;; iterate over items in res
- (map (lambda (h) ;; iterate over items in hed
- (append r (list h)))
- hed))
- res)))))
- ;; (print "newres1: " newres)
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres)))
- (let ((newres (if (null? res)
- (list (list hed))
- (map (lambda (r)
- (append r (list hed)))
- res))))
- ;; (print "newres2: " newres)
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres))))))
-
-;; multi-part expand
-;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f
-;;
-(define (runconfig:expand target)
- (let* ((parts (map (lambda (x)
- (string-split x ","))
- (string-split target "/"))))
- (map (lambda (x)
- (string-intersperse x "/"))
- (runconfig:combinations parts))))
-
-;; multi-target expansion
-;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y
-;;
-(define (runconfig:expand-target target-strs)
- (delete-duplicates
- (apply append (map runconfig:expand (string-split target-strs " ")))))
-
-#|
- (if (null? target-strs)
- '()
- (let loop ((hed (car target-strs))
- (tal (cdr target-strs))
- (res '()))
- ;; first break all parts into individual target patterns
- (if (string-index hed " ") ;; this is a multi-target target
- (let ((newres (append (string-split hed " ") res)))
- (runconfig:expand-target newres))
- (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated
-
-|#
-
-;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
-;;
-(define (full-runconfigs-read)
-;; in the envprocessing branch the below code replaces the further below code
-;; (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"))
- #f))
- (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
- (if (and cfgf
- (common:file-exists? cfgf)
- (file-write-access? cfgf)
- (common:use-cache?))
- (configf:read-alist cfgf)
- (let* ((keys (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*)
- (if key-vals
- (for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
- key-vals))
- ;; (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)
- (file-write-access? rundir))
- (begin
- (if (not (common:in-running-test?))
- (configf:write-alist data cfgf))
- ;; force re-read of megatest.config - this resolves circular references between megatest.config
- (launch:setup force-reread: #t)
- ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
- )) ;; we can safely cache megatest.config since we have a valid runconfig
- data))))
-
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -17,25 +17,75 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit runsmod))
+
+
+(declare (unit mtmod))
(declare (uses commonmod))
-(declare (uses testsmod))
+(declare (uses dbmod))
+(declare (uses launchmod))
+(declare (uses mtargs))
+(declare (uses mtconfigf))
(declare (uses mtmod))
+(declare (uses pgdbmod))
+(declare (uses rmtmod))
+(declare (uses servermod))
+(declare (uses stml2))
+(declare (uses subrunmod))
+(declare (uses tasksmod))
+(declare (uses testsmod))
+(declare (uses itemsmod))
(module runsmod
*
-(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+(import scheme chicken data-structures extras ports files)
+
(import
- commonmod
- testsmod
- mtmod)
+ (prefix base64 base64:)
+ (prefix mtargs args:)
+ (prefix mtconfigf configf:)
+ (prefix sqlite3 sqlite3:)
+ call-with-environment-variables
+ commonmod
+ csv
+ dbmod
+ directory-utils
+ format
+ itemsmod
+ matchable
+ message-digest
+ md5
+ mtmod
+ pgdbmod
+ ports
+ posix
+ regex
+ rmtmod
+ servermod
+ srfi-1
+ srfi-1
+ srfi-13
+ srfi-18
+ srfi-18
+ srfi-69
+ srfi-69
+ stml2
+ subrunmod
+ tasksmod
+ testsmod
+ typed-records
+ z3
+ )
;; (use (prefix ulex ulex:))
+(include "run_records.scm")
+(include "db_records.scm")
+(include "test_records.scm")
+(include "key_records.scm")
;; (include "common_records.scm")
(defstruct runs:dat
reglen regfull
runname max-concurrent-jobs run-id
@@ -2424,11 +2474,11 @@
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
- (runconfig (read-config runconfigf #f #t environ-patt: #f)))
+ (runconfig (configf:read-config runconfigf #f #t environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
(begin
(debug:print-error 0 *default-log-port* "[" (args:get-arg "-reqtarg") "] not found in " runconfigf)
@@ -6880,8 +6930,554 @@
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
(rmt:general-call 'set-test-comment run-id cmt test-id)))))
+;;======================================================================
+;; read a config file, loading only the section pertinent
+;; to this run field1val/field2val/field3val ...
+;;======================================================================
+
+(define (runconfig:read fname target environ-patt)
+ (let ((ht (make-hash-table)))
+ (if target (hash-table-set! ht target '()))
+ (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
+
+;; NB// to process a runconfig ensure to use environ-patt with target!
+;;
+(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 (common:args-get-target)
+ (get-environment-variable "MT_TARGET")
+ (begin
+ (debug:print-error 0 *default-log-port* "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?
+ ;; NOTE: Should be setting env vars based on (target|default)
+ (confdat (runconfig:read fname thekey environ-patt))
+ (whatfound (make-hash-table))
+ (finaldat (make-hash-table))
+ (sections (list "default" thekey)))
+ (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
+ (debug:print 4 *default-log-port* "Using key=\"" thekey "\"")
+
+ (if change-env
+ (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
+ (lambda (keyval)
+ (safe-setenv (car keyval)(cadr keyval)))
+ keyvals))
+
+ (for-each
+ (lambda (section)
+ (let ((section-dat (hash-table-ref/default confdat section #f)))
+ (if section-dat
+ (for-each
+ (lambda (envvar)
+ (let ((val (cadr (assoc envvar section-dat))))
+ (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
+ (if (and (string? envvar)
+ (string? val)
+ change-env)
+ (safe-setenv envvar val))
+ (hash-table-set! finaldat envvar val)))
+ (map car section-dat)))))
+ sections)
+ (if already-seen
+ (begin
+ (debug:print 2 *default-log-port* "Key settings found in runconfigs.config:")
+ (for-each (lambda (fullkey)
+ (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
+ sections)
+ (debug:print 2 *default-log-port* "---")
+ (set! *already-seen-runconfig-info* #t)))
+ ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses
+ confdat
+ ))
+
+(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 (common:args-get-target)
+ targ-from-db
+ (get-environment-variable "MT_TARGET"))))
+ (pop-directory)
+ (if (common:file-exists? runconfigf)
+ (setup-env-defaults runconfigf run-id #t keyvals
+ environ-patt: (conc "(default"
+ (if targ
+ (conc "|" targ ")")
+ ")")))
+ (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf))))
+
+;; given (a (b c) d) return ((a b d)(a c d))
+;; NOTE: this feels like it has been done before - perhaps with items handling?
+;;
+(define (runconfig:combinations inlst)
+ (let loop ((hed (car inlst))
+ (tal (cdr inlst))
+ (res '()))
+ ;; (print "res: " res " hed: " hed)
+ (if (list? hed)
+ (let ((newres (if (null? res) ;; first time through convert incoming items to list of items
+ (map list hed)
+ (apply append
+ (map (lambda (r) ;; iterate over items in res
+ (map (lambda (h) ;; iterate over items in hed
+ (append r (list h)))
+ hed))
+ res)))))
+ ;; (print "newres1: " newres)
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))
+ (let ((newres (if (null? res)
+ (list (list hed))
+ (map (lambda (r)
+ (append r (list hed)))
+ res))))
+ ;; (print "newres2: " newres)
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+;; multi-part expand
+;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f
+;;
+(define (runconfig:expand target)
+ (let* ((parts (map (lambda (x)
+ (string-split x ","))
+ (string-split target "/"))))
+ (map (lambda (x)
+ (string-intersperse x "/"))
+ (runconfig:combinations parts))))
+
+;; multi-target expansion
+;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y
+;;
+(define (runconfig:expand-target target-strs)
+ (delete-duplicates
+ (apply append (map runconfig:expand (string-split target-strs " ")))))
+
+#|
+ (if (null? target-strs)
+ '()
+ (let loop ((hed (car target-strs))
+ (tal (cdr target-strs))
+ (res '()))
+ ;; first break all parts into individual target patterns
+ (if (string-index hed " ") ;; this is a multi-target target
+ (let ((newres (append (string-split hed " ") res)))
+ (runconfig:expand-target newres))
+ (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated
+
+|#
+
+;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
+;;
+(define (full-runconfigs-read)
+;; in the envprocessing branch the below code replaces the further below code
+;; (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"))
+ #f))
+ (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
+ (if (and cfgf
+ (common:file-exists? cfgf)
+ (file-write-access? cfgf)
+ (common:use-cache?))
+ (configf:read-alist cfgf)
+ (let* ((keys (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*)
+ (if key-vals
+ (for-each (lambda (kt)
+ (setenv (car kt) (cadr kt)))
+ key-vals))
+ ;; (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)
+ (file-write-access? rundir))
+ (begin
+ (if (not (common:in-running-test?))
+ (configf:write-alist data cfgf))
+ ;; force re-read of megatest.config - this resolves circular references between megatest.config
+ (launch:setup force-reread: #t)
+ ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
+ )) ;; we can safely cache megatest.config since we have a valid runconfig
+ data))))
+
+
+;;======================================================================
+;;
+;;======================================================================
+
+;; NOT CURRENTLY USED - commented out as it has unresolved dependencies
+;;
+#;(define (archive:main linktree target runname testname itempath options)
+ (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
+ (flavor 'plain) ;; type of machine to run jobs on
+ (maxload 1.5) ;; max allowed load for this work
+ (adisks (archive:get-archive-disks)))
+ ;; get testdir size
+ ;; - hand off du to job mgr
+ (if (and (common:file-exists? testdir)
+ (file-is-writable? testdir))
+ (let* ((dused (jobrunner:run-job
+ flavor ;; machine type
+ maxload ;; max allowed load
+ '() ;; prevars - environment vars to set for the job
+ common:get-disk-space-used ;; if a proc call it, if a string it is a unix command
+ (list testdir)))
+ (apath (archive:get-archive testname itempath dused)))
+ (jobrunner:run-job
+ flavor
+ maxload
+ '()
+ archive:run-bup
+ (list testdir apath))))))
+
+;; Get archive disks from megatest.config
+;;
+(define (archive:get-archive-disks)
+ (let ((section (configf:get-section *configdat* "archive-disks")))
+ (if section
+ section
+ '())))
+
+;; look for the best candidate archive area, else create new
+;; area
+;;
+(define (archive:get-archive testname itempath dused)
+ ;; look up in archive_allocations if there is a pre-used archive
+ ;; with adequate diskspace
+ ;;
+ (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
+ (candidate-disks (map (lambda (block)
+ (list
+ (vector-ref block 1) ;; archive-area-name
+ (vector-ref block 2))) ;; disk-path
+ existing-blocks)))
+ (or (common:get-disk-with-most-free-space candidate-disks dused)
+ (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath))))
+
+;; allocate a new archive area
+;;
+(define (archive:allocate-new-archive-block blockid-cache run-area-home testsuite-name dneeded target run-name test-name)
+ (let ((key (conc testsuite-name "/" target "/" run-name "/" test-name)))
+ (if (hash-table-exists? blockid-cache key)
+ (hash-table-ref blockid-cache key)
+ (let* ((pscript (configf:lookup *configdat* "archive" "pathscript"))
+ (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
+ (apath (if pscript
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: script \"" pscript-cmd "\" failed to run properly.")
+ (exit 1))
+ (with-input-from-pipe
+ pscript-cmd
+ read-line))
+ #f)) ;; this is the user-calculated archive path
+ (adisks (archive:get-archive-disks))
+ (best-disk (common:get-disk-with-most-free-space adisks dneeded)))
+ (if best-disk
+ (let* ((bdisk-name (car best-disk))
+ (bdisk-path (cdr best-disk))
+ (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5))
+ (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
+ (archive-name (if apath
+ apath
+ (let ((sec (current-seconds)))
+ (conc (time->string (seconds->local-time sec) "%Y")
+ "_q" (seconds->quarter sec) "/"
+ testsuite-name "_" area-key))))
+ (archive-path (conc bdisk-path "/" archive-name))
+ (block-id (rmt:archive-register-block-name bdisk-id archive-path)))
+ ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
+ (if block-id ;; (and block-id allocation-id)
+ (let ((res (cons block-id archive-path)))
+ (hash-table-set! blockid-cache key res)
+ res)
+ #f))
+ #f)) ;; no best disk found
+ )))
+
+;; archive - run bup
+;;
+;; 1. create the bup dir if not exists
+;; 2. start the du of each directory
+;; 3. gen index
+;; 4. save
+;;
+(define (archive:run-bup 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* ((blockid-cache (make-hash-table))
+ (tsname (common:get-testsuite-name))
+ (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
+ (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area
+ (disk-groups (make-hash-table)) ;;
+ (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
+ (test-dirs (make-hash-table))
+ (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
+ (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
+ (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)))
+ (print-prefix "Running: ") ;; change to #f to turn off printing
+ (preclean-spec (configf:get-section *configdat* "archive-preclean")))
+
+ ;; (tests:match patt testname itempath)
+
+ ;; from the test info bin the path to the test by stem
+ ;;
+ (for-each
+ (lambda (test-dat)
+ (let* ((item-path (db:test-get-item-path test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat))
+ (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
+
+ (toplevel/children (and (db:test-get-is-toplevel test-dat)
+ (> (rmt:test-toplevel-num-items run-id test-name) 0)))
+ (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
+ ;; note the trailing slash to get the dir inspite of it being a link
+ (test-path (conc linktree "/" test-partial-path))
+ (mutex-lock! rp-mutex)
+ (test-physical-path (if (common:file-exists? test-path)
+ (common:real-path test-path)
+ #f))
+ (mutex-unlock! rp-mutex)
+ (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f))
+ (test-base (if (and partial-path-index
+ test-physical-path )
+ (substring test-physical-path
+ 0
+ partial-path-index)
+ #f))
+ ;; we need our archive dir checked for every test to enable folks who want to store other ways.
+ (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
+ (archive-dir (if archive-info (cdr archive-info) #f))
+ (archive-id (if archive-info (car archive-info) -1))
+
+ )
+
+ (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")
+ (debug:print 0 *default-log-port* " disks: "
+ (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
+ (exit 1))
+ (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path))
+
+ ;; preclean the test directory per the spec if provided
+ (if (not (null? preclean-spec)) ;; we've been asked to preclean before archiving
+ (let loop ((spec (car preclean-spec))
+ (tail (cdr preclean-spec)))
+ (if (> (length spec) 1)
+ (let ((testspec (car spec))
+ (rules (cadr spec)))
+ (if (tests:match testspec test-name item-path)
+ (begin
+ (debug:print 0 *default-log-port* "INFO: cleanup requested for " test-physical-path)
+ (common:dir-clean-up test-physical-path rules remove-empty: #t))
+ (if (not (null? tail))
+ (loop (car tail)(cdr tail)))))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: bad spec line in [archive-preclean] section. \"" spec "\"")
+ (if (not (null? tail))(loop (car tail)(cdr tail)))))))
+ (cond
+ (toplevel/children
+ (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id
+ " as it is a toplevel test with children"))
+ ((not (common:file-exists? test-path))
+ (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path
+ " as path " test-path " does not exist"))
+ (else
+ (debug:print 0 *default-log-port*
+ "From test-dat=" test-dat " derived the following:\n"
+ "test-partial-path = " test-partial-path "\n"
+ "test-path = " test-path "\n"
+ "test-physical-path = " test-physical-path "\n"
+ "partial-path-index = " partial-path-index "\n"
+ "test-base = " test-base)
+ (hash-table-set! disk-groups test-base
+ (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
+ (hash-table-set! test-groups test-base
+ (cons test-dat (hash-table-ref/default test-groups test-base '())))
+ (hash-table-set! arch-groups test-base
+ (cons archive-info (hash-table-ref/default arch-groups test-base '())))
+ (hash-table-set! test-dirs test-id test-path)))))
+ ;; test-path))))
+ tests)
+ (debug:print 0 *default-log-port* "INFO: DISK GROUPS=" (hash-table->alist disk-groups))
+ ;; for each disk-group, initialize the bup area if needed
+ (for-each
+ (lambda (test-base)
+ (let* ((disk-group (hash-table-ref disk-groups test-base))
+ (arch-group (hash-table-ref arch-groups test-base))
+ (arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
+ (archive-id (car arch-info))
+ (archive-dir (cdr arch-info)))
+ (debug:print 0 *default-log-port* "Processing disk-group " test-base)
+ (let* ((test-paths (hash-table-ref disk-groups test-base)))
+ (if (not (common:file-exists? archive-dir))
+ (create-directory archive-dir #t))
+ (case archiver
+ ((bup) ;; Archive using bup
+ (let* ((bup-init-params (list "-d" archive-dir "init"))
+ (bup-index-params (append (list "-d" archive-dir "index") test-paths))
+ (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
+ (conc "-" compress) ;; or (conc "--compress=" compress)
+ "-n" (conc (common:get-testsuite-name) "-" run-id)
+ (conc "--strip-path=" test-base) ;; if we push to the directory do we need this?
+ )
+ test-paths)))
+ (if (not (common:file-exists? (conc archive-dir "/HEAD")))
+ (begin
+ ;; replace this with jobrunner stuff enventually
+ (debug:print-info 0 *default-log-port* "Init bup in " archive-dir)
+ ;; (mutex-lock! bup-mutex)
+ (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)
+ ;; (mutex-unlock! bup-mutex)
+ ))
+ (debug:print-info 0 *default-log-port* "Indexing data to be archived")
+ ;; (mutex-lock! bup-mutex)
+ (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
+ (debug:print-info 0 *default-log-port* "Archiving data with bup")
+ (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ ((7z tar)
+ (for-each
+ (lambda (test-dat)
+ (let* ((test-id (db:test-get-id test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (item-path (db:test-get-item-path test-dat))
+ (test-full-name (db:test-make-full-name test-name item-path))
+ (run-id (db:test-get-run_id test-dat))
+ (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
+ (run-name (rmt:get-run-name-from-id run-id))
+ (source-dir (hash-table-ref test-dirs test-id)) ;; (conc test-base "/" test-name "/" item-path))
+ (target-dir (string-substitute "/$" "" (conc archive-dir "/" target "/" run-name "/" test-full-name))))
+ ;; create the test and item-path levels under archive-dir
+ (create-directory (pathname-directory target-dir) #t)
+ (run-n-wait
+ (conc
+ (string-substitute "ARCHIVE_NAME" target-dir archiver-cmd) " "
+ "."
+ )
+ print-cmd: print-prefix
+ run-dir: source-dir)))
+ (hash-table-ref test-groups test-base))))
+ ;; (mutex-unlock! bup-mutex)
+ (for-each
+ (lambda (test-dat)
+ (let ((test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat)))
+ (rmt:test-set-archive-block-id run-id test-id archive-id)
+ (if (member archive-command '("save-remove"))
+ (runs:remove-test-directory test-dat 'archive-remove))))
+ (hash-table-ref test-groups test-base)))))
+ (hash-table-keys disk-groups))
+ #t))
+
+(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 (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)
+ ;; When restoring test-dat will initially contain an old and invalid path to the test
+ (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk.
+ (item-path (db:test-get-item-path test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat))
+ (keyvals (rmt:get-key-val-pairs run-id))
+ (target (string-intersperse (map cadr keyvals) "/"))
+
+ (toplevel/children (and (db:test-get-is-toplevel test-dat)
+ (> (rmt:test-toplevel-num-items run-id test-name) 0)))
+ (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
+ ;; note the trailing slash to get the dir inspite of it being a link
+ (test-path (conc linktree "/" test-partial-path))
+ ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory
+ (mutex-lock! rp-mutex)
+ (prev-test-physical-path (if (common:file-exists? test-path)
+ ;; (read-symbolic-link test-path #t)
+ (common:real-path test-path)
+ #f))
+ (mutex-unlock! rp-mutex)
+ (new-test-physical-path (conc best-disk "/" test-partial-path))
+ (archive-block-id (db:test-get-archived test-dat))
+ (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
+ (archive-path (if (vector? archive-block-info)
+ (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
+ #f)) ;; no archive found?
+ (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
+
+ ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
+ ;;
+ (if (and (not toplevel/children) ;; special handling needed for toplevel with children
+ prev-test-physical-path
+ (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
+ (let* ((base (pathname-directory prev-test-physical-path))
+ (dirn (pathname-file prev-test-physical-path))
+ (newn (conc base "/." dirn)))
+ (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
+ (rename-file prev-test-physical-path newn)))
+
+ (if (and archive-path ;; no point in proceeding if there is no actual archive
+ (not toplevel/children))
+ (begin
+ ;; CREATE WORK AREA
+ ;; test-src-path == #f ==> don't copy in data from tests directory
+ ;; itemdat == string ==> use directly
+ (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
+
+ ;; 1. Get the block id from the test info
+ ;; 2. Get the block data given the block id
+ ;; 3. Construct the paths etc. for the following command:
+ ;;
+ ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
+ ;; DO BUP RESTORE
+ (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
+ (new-test-path (if (vector? new-test-dat )
+ (db:test-get-rundir new-test-dat)
+ (begin
+ (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
+ (exit 1))))
+ ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
+ (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
+ (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
+ ;; (mutex-lock! bup-mutex)
+ (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
+ ;; (mutex-unlock! bup-mutex)
+ (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
+ (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
+ (filter vector? tests))))
+
)