88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
-
+
|
(hash-table-ref blockid-cache key)
(let* ((pscript (configf:lookup *configdat* "archive" "pathscript"))
(pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
(apath (if pscript
(handle-exceptions
exn
(begin
(debug:print 0 *current-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly.")
(debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly.")
(exit 1))
(with-input-from-pipe
pscript-cmd
read-line))
#f)) ;; this is the user-calculated archive path
(adisks (archive:get-archive-disks))
(best-disk (common:get-disk-with-most-free-space adisks dneeded)))
|
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
-
+
-
+
|
(block-id (rmt:archive-register-block-name bdisk-id archive-path)))
;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
(if block-id ;; (and block-id allocation-id)
(let ((res (cons block-id archive-path)))
(hash-table-set! blockid-cache key res)
res)
(begin
(debug:print 0 *current-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", block-id=" block-id)
(debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path)
#f)))
(begin
(debug:print 0 *current-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", block-id=" block-id)
(debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", block-id=" block-id)
#f)))))) ;; no best disk found
;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
;; 3. gen index
|