Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -80,29 +80,49 @@
     (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 run-area-home testsuite-name dneeded)
-  (let* ((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  (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)
-	      (cons block-id archive-path)
-	      #f))
-	#f)))
+(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
@@ -111,27 +131,19 @@
 ;;
 (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* ((min-space    (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
-	 (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space))
-	 (archive-dir  (if archive-info (cdr archive-info) #f))
-	 (archive-id   (if archive-info (car archive-info) -1))
+  (let* ((blockid-cache (make-hash-table))
+	 (tsname       (common:get-testsuite-name))
+	 (min-space    (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
 	 (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     (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")
-	  (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"))
 
     ;; from the test info bin the path to the test by stem
     ;;
     (for-each
      (lambda (test-dat)
@@ -155,27 +167,47 @@
 	      (test-base         (if (and partial-path-index 
 					  test-physical-path )
 				     (substring test-physical-path
 						0
 						partial-path-index)
-				     #f)))
+				     #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))
 	 
  	 (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"))
+	   (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"))
+	   (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! 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)

Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -2072,18 +2072,22 @@
 		    action)
 		   ((run-wait)
 		    (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete"))
 		   ((archive)
 		    (debug:print 1 *default-log-port* "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname"))
-		    (set! worker-thread (make-thread (lambda ()
-						       (case (string->symbol (args:get-arg "-archive"))
-							 ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
-							 ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
-							 (else 
-							  (debug:print-error 0 *default-log-port* "unrecognised sub command to -archive. Run \"megatest\" to see help")
-							  (exit))))
-						     "archive-bup-thread"))
+		    (set! worker-thread
+			  (make-thread
+			   (lambda ()
+			     (case (string->symbol (args:get-arg "-archive"))
+			       ((save save-remove keep-html)
+				(archive:run-bup (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
+			       ((restore)
+				(archive:bup-restore (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
+			       (else 
+				(debug:print-error 0 *default-log-port* "unrecognised sub command to -archive. Run \"megatest\" to see help")
+				(exit))))
+			   "archive-bup-thread"))
 		    (thread-start! worker-thread))
 		   (else
 		    (debug:print-info 0 *default-log-port* "action not recognised " action)))
 		 
 		 ;; actions that operate on one test at a time can be handled below