11
12
13
14
15
16
17
18
19
20
21
22
23
24
|
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
+
+
+
|
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(import (prefix sqlite3 sqlite3:))
(declare (unit archive))
(declare (uses db))
(declare (uses common))
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
;;
;;======================================================================
(define (archive:main linktree target runname testname itempath options)
(let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
|
80
81
82
83
84
85
86
87
|
83
84
85
86
87
88
89
90
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(archive-path (conc bdisk-path "/" archive-name))
(block-id (rmt:archive-register-block-name bdisk-id archive-path))
(allocation-id (rmt:archive-allocate-test-to-block block-id testname itempath)))
(if (and block-id allocation-id)
archive-path
#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 run-name tests)
(let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(linktree (configf:lookup *configdat* "setup" "linktree"))
(test-paths (filter
string?
(map (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))))
(if toplevel/children
#f
(conc linktree "/" 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
tests)))
;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-")
(bup-init-params (list "-d" archive-dir))
(bup-index-params (append (list "-d" archive-dir "index") test-paths))
(bup-save-params (append (list "-d" archive-dir "save" "-n" (common:get-testsuite-name))
test-paths)))
(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)))
(debug:print-info 0 "Indexing data to be archived")
(run-n-wait bup-exe params: bup-index-params)
(debug:print-info 0 "Archiving data with bup")
(run-n-wait bup-exe params: bup-save-params)))
|