Megatest

Diff
Login

Differences From Artifact [212cc6c596]:

To Artifact [1acc296954]:


183
184
185
186
187
188
189
190

191
192
193
194
195
196
197
198
199
183
184
185
186
187
188
189

190


191
192
193
194
195
196
197







-
+
-
-







				     (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))
	      (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: "
309
310
311
312
313
314
315

316

317
318





319
320
321
322
323
324
325
307
308
309
310
311
312
313
314
315
316


317
318
319
320
321
322
323
324
325
326
327
328







+

+
-
-
+
+
+
+
+







		    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)))
                 (debug:print-info 0 *default-log-port* "|"archive-command"|")
		(rmt:test-set-archive-block-id run-id test-id archive-id)
                (debug:print-info 0 *default-log-port* "|"archive-command"|" (member (symbol->string archive-command) '("save-remove")) (string? archive-command))
		(if (member archive-command '("save-remove"))
		    (runs:remove-test-directory test-dat 'archive-remove))))

		(if (member (symbol->string archive-command) '("save-remove"))
                    (begin 
                     (debug:print-info 0 *default-log-port* "remove testdat")
		    (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
  ;;