1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
-
+
|
;; Copyright 2006-2014, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format md5 message-digest)
(import (prefix sqlite3 sqlite3:))
(declare (unit archive))
(declare (uses db))
(declare (uses common))
(include "common_records.scm")
|
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
|
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
|
-
+
-
+
-
+
-
+
+
+
+
-
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
'()
archive:run-bup
(list testdir apath))))))
;; Get archive disks from megatest.config
;;
(define (archive:get-archive-disks)
(let ((section (configf:get-section *configdat* "archivedisks")))
(let ((section (configf:get-section *configdat* "archive-disks")))
(if section
(map cdr section)
section
'())))
;; look for the best candidate archive area, else create new
;; area
;;
(define (archive:get-archive testname itempath dused)
;; look up in archive_allocations if there is a pre-used archive
;; with adequate diskspace
;;
(let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
(candidate-disks (map (lambda (block)
(list
(vector-ref block 1) ;; archive-area-name
(vector-ref block 2))) ;; disk-path
existing-blocks)))
(or (common:get-disk-with-most-free-space candidate-disks dused)
(archive:allocate-new-archive-block testname itempath))))
;; allocate a new archive area
;;
(define (archvie:allocate-new-archive-block testname itempath dneeded)
(define (archive:allocate-new-archive-block run-area-home testsuite-name dneeded)
(let* ((adisks (archive:get-archive-disks))
(best-disk (common:get-disk-with-most-free-space adisks dneeded)))
(if best-disk
(let* ((bdisk-name (car best-disk))
(bdisk-path (cdr best-disk))
(bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
(archive-name (time->string (seconds->local-time (current-seconds)) "ww%W.%u"))
(archive-name (conc (time->string (seconds->local-time (current-seconds)) "%Y")
"_q" (seconds->quarter sec) "/"
testsuite-name "_" (substring (message-digest-string (md5-primitive) (get-environment-variable "PATH")) 0 5)))
(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))
#f)))))
#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-id run-name tests)
(let* ((disk-groups (make-hash-table))
(define (archive:run-bup archive-dir-in run-id run-name tests)
(let* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
(archive-dir (if (equal? archive-dir-in "-") ;; auto allocate an archive dir
(archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)
archive-dir-in))
(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")))
(if (not archive-dir) ;; no archive disk found, this is fatal
(begin
(debug:print 0 "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 " use [archive] minspace to specify minimum available space")
(debug:print 0 " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
(exit 1))
(debug:print-info 0 "Using path " archive-dir " for archiving"))
;; 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))
|