Megatest

Check-in [50237f6e1f]
Login
Overview
Comment:fixed-save
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-broken
Files: files | file ages | folders
SHA1: 50237f6e1f5f369b5e1022774427028c4dba7d6b
User & Date: mrwellan on 2020-05-05 12:38:27
Other Links: branch diff | manifest | tags
Context
2020-05-05
12:55
Fixed the first run archive disk not found issue check-in: 64aa9347d5 user: mrwellan tags: v1.65-broken
12:38
fixed-save check-in: 50237f6e1f user: mrwellan tags: v1.65-broken
11:30
Added -inlcude support to save and get for archive check-in: e28be4def5 user: mrwellan tags: v1.65-broken
Changes

Modified archive.scm from [09abb4e185] to [e3fbfd8139].

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 "ERROR: script \"" pscript-cmd "\" failed to run properly.")
				   (debug:print 0 *current-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)))
114
115
116
117
118
119
120


121
122




123
124
125
126
127
128
129
130
114
115
116
117
118
119
120
121
122


123
124
125
126

127
128
129
130
131
132
133







+
+
-
-
+
+
+
+
-







		     (archive-path  (conc bdisk-path "/" archive-name))
		     (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)
		    #f))
	      #f)) ;; no best disk found
		      #f)))
	      (begin
		(debug:print 0 *current-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
;; 4. save