Overview
| Comment: | Flattened unnecessary hierarchy from paths in bup repositories |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.60 |
| Files: | files | file ages | folders |
| SHA1: |
4aa76fc69236171ed044cf955e7401f7 |
| User & Date: | matt on 2014-12-15 22:51:56 |
| Other Links: | branch diff | manifest | tags |
Context
|
2014-12-15
| ||
| 23:04 | Switch to --strip-path from --strip check-in: a771721f7f user: matt tags: v1.60 | |
| 22:51 | Flattened unnecessary hierarchy from paths in bup repositories check-in: 4aa76fc692 user: matt tags: v1.60 | |
| 00:16 | Fixed db running bug check-in: 6eef552c2e user: matt tags: v1.60 | |
Changes
Modified archive.scm from [73138d52b1] to [20f948bb6a].
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | ;; ;; 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 run-id run-name tests) | > | | | > > | | | | | | | | | > | | > > > > > > > > > | | | > > > > > > > > > | | > > > > > | | | | | | > | | | | | | | | | | | | | > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
;;
;; 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 run-id run-name tests)
(let* ((disk-groups (make-hash-table))
(bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(compress (or (configf:lookup *configdat* "archive" "compress") "9"))
(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))
(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)))
(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 '())))
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)
"--strip" 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)))
(hash-table-keys disk-groups))
#t))
|
Modified runs.scm from [60a135ce85] to [50b11e0aa4].
| ︙ | ︙ | |||
1563 1564 1565 1566 1567 1568 1569 | (if (null? new-tests) (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests))))) ((archive) (if (not toplevel-with-children) (begin (debug:print-info 0 "Estimating disk space usage for " test-fulln) | | > > | 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 |
(if (null? new-tests)
(debug:print-info 1 "Run completed according to zero tests matching provided criteria.")
(loop (car new-tests)(cdr new-tests)))))
((archive)
(if (not toplevel-with-children)
(begin
(debug:print-info 0 "Estimating disk space usage for " test-fulln)
(debug:print-info 0 " " (common:get-disk-space-used (conc run-dir "/")))))
(if (not (null? tal))
(loop (car tal)(cdr tal))))
)))
)
(if worker-thread (thread-join! worker-thread))))))
;; remove the run if zero tests remain
(if (eq? action 'remove-runs)
(let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
(if (null? remtests) ;; no more tests remaining
|
| ︙ | ︙ |