Megatest

	       (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)))

;; 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-dir-in 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* ((min-space   (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
	 (archive-info (if (equal? archive-dir-in "-") ;; auto allocate an archive dir
			   (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)
			   (cons archive-dir-in 0))) ;; THIS WONT WORK!!!
	 (archive-dir (if archive-info (cdr archive-info) archive-disk-in))
	 (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")))

    (if (not archive-dir) ;; no archive disk found, this is fatal
	(begin
	  (debug:print 0 "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 "       use [archive] minspace to specify minimum available space")
	  (debug:print 0 "   disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n         "))
	  (exit 1))
	(debug:print-info 0 "Using path " archive-dir " for archiving"))

    ;; 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

			    "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))

	     (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)))
	  (hash-table-ref test-groups disk-group))))
     (hash-table-keys disk-groups))
    #t))

(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
		      archive-block-id test-id))))
 

;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;;   (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
;; 	 (db           (db:dbdat-get-db dbdat))
;; 	 (res          '())
;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space