Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -145,10 +145,100 @@
 				     (substring test-physical-path
 						0
 						partial-path-index)
 				     #f)))
 	 
+ 	 (if (or toplevel/children
+		 (not (file-exists? test-path)))
+	     #f
+	     (begin
+	       (debug:print 0
+			    "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 '())))
+	       test-path))))
+     tests)
+    ;; for each disk-group
+    (for-each 
+     (lambda (disk-group)
+       (debug:print 0 "Processing disk-group " disk-group)
+       (let* ((test-paths (hash-table-ref disk-groups disk-group))
+	      ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-")
+	      (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=" disk-group))
+					test-paths))
+	      (print-prefix      #f)) ;; "Running: ")) ;; change to #f to turn off printing
+	 (if (not (file-exists? archive-dir))
+	     (create-directory archive-dir #t))
+	 (if (not (file-exists? (conc archive-dir "/HEAD")))
+	     (begin
+	       ;; replace this with jobrunner stuff enventually
+	       (debug:print-info 0 "Init bup in " archive-dir)
+	       (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
+	 (debug:print-info 0 "Indexing data to be archived")
+	 (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
+	 (debug:print-info 0 "Archiving data with bup")
+	 (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)
+	 (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 disk-group))))
+     (hash-table-keys disk-groups))
+    #t))
+
+(define (archive:bup-restore archive-command run-id run-name tests)  ;; 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* ((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"))
+	 (linktree     (configf:lookup *configdat* "setup" "linktree")))
+
+    ;; 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 "/" (runs:make-full-test-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))
+	      (test-physical-path (if (file-exists? test-path) (read-symbolic-link test-path #t) #f))
+	      (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)))
+	 
+	 ;; CREATE WORK AREA
+	 (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2))
+	 
+	 ;; DO BUP RESTORE
+
+
+
  	 (if (or toplevel/children
 		 (not (file-exists? test-path)))
 	     #f
 	     (begin
 	       (debug:print 0

Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -1473,11 +1473,14 @@
 		   ((run-wait)
 		    (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
 		   ((archive)
 		    (debug:print 1 "Archiving data for run: " runkey " " (db:get-value-by-header run header "runname"))
 		    (set! worker-thread (make-thread (lambda ()
-						       (archive:run-bup (args:get-arg "-archive") run-id run-name tests))
+						       (case (string->symbol (args:get-arg "-archive"))
+							 ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests))
+							 ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests))
+							 (else (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help"))))
 						     "archive-bup-thread"))
 		    (thread-start! worker-thread))
 		   (else
 		    (debug:print-info 0 "action not recognised " action)))