Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -131,20 +131,27 @@ ;; (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-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"))) - - + (let* ((blockid-cache (make-hash-table)) + (tsname (common:get-testsuite-name)) + (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 ;; 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)) @@ -204,51 +211,83 @@ "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 *default-log-port* "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 (common:file-exists? archive-dir)) - (create-directory archive-dir #t)) - (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) - ;; (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 disk-group)))) - (hash-table-keys disk-groups)) + (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-testsuite-name) "-" 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 ;; Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -442,11 +442,13 @@ (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt? - (and (not (string-null? key))(equal? "!" (substring key 0 1))))) ;; ! as leading character is a signature to NOT export to the environment + (and (not (string-null? key))(equal? "!" (substring key 0 1))) ;; ! as leading character is a signature to NOT export to the environment + ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs + )) (realval (if envar (config:eval-string-in-environment val) val))) (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -20,11 +20,11 @@ ;;====================================================================== ;; Process convience utils ;;====================================================================== -(use regex) +(use regex directory-utils) (declare (unit process)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) @@ -139,30 +139,38 @@ (append result (list curr))) result)))) ;; here is an example line where the shell is sh or bash ;; "find / -print 2&>1 > findall.log" -(define (run-n-wait cmdline #!key (params #f)(print-cmd #f)) +(define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f)) (if print-cmd (debug:print 0 *default-log-port* (if (string? print-cmd) print-cmd "") + (if run-dir (conc "Run in " run-dir ";") "") cmdline (if params - (string-intersperse params " ") + (conc " " (string-intersperse params " ")) ""))) + (if (and run-dir + (directory-exists? run-dir)) + (push-directory run-dir)) (let ((pid (if params (process-run cmdline params) (process-run cmdline)))) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (if (eq? pid-val 0) (begin (thread-sleep! 2) (loop (+ i 1))) - (values pid-val exit-status exit-code)))))) + (begin + (if (and run-dir + (directory-exists? run-dir)) + (pop-directory)) + (values pid-val exit-status exit-code))))))) ;;====================================================================== ;; MISC PROCESS RELATED STUFF ;;======================================================================