@@ -28,367 +28,5 @@
 (import commonmod)
 
 (include "common_records.scm")
 (include "db_records.scm")
 
-;;======================================================================
-;; 
-;;======================================================================
-
-;; NOT CURRENTLY USED
-;;
-(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-area-name *alldat*))
-	 (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-area-name *alldat*) "-" 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-area-name *alldat*) "-" 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))))
-