145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
(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))
(test-name (db:test-get-testname test-dat))
(test-id (db:test-get-id test-dat))
|
|
>
>
>
>
|
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
(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
(preclean-spec (configf:get-section *configdat* "archive-preclean")))
;; (tests:match patt testname itempath)
;; 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))
|
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
(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: "
(string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
(exit 1))
(debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path))
(cond
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
(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: "
(string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
(exit 1))
(debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path))
;; preclean the test directory per the spec if provided
(if (not (null? preclean-spec)) ;; we've been asked to preclean before archiving
(let loop ((spec (car preclean-spec))
(tail (cdr preclean-spec)))
(if (> (length spec) 1)
(let ((testspec (car spec))
(rules (cadr spec)))
(if (tests:match testspec test-name item-path)
(begin
(debug:print 0 *default-log-port* "INFO: cleanup requested for " test-physical-path)
(common:dir-clean-up test-physical-path rules remove-empty: #t))
(if (not (null? tail))
(loop (car tail)(cdr tail)))))
(begin
(debug:print 0 *default-log-port* "ERROR: bad spec line in [archive-preclean] section. \"" spec "\"")
(if (not (null? tail))(loop (car tail)(cdr tail)))))))
(cond
(toplevel/children
(debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id
" as it is a toplevel test with children"))
((not (common:file-exists? test-path))
(debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path
" as path " test-path " does not exist"))
(else
|