Megatest

Check-in [e05e127ba0]
Login
Overview
Comment:Improved feedback when archiving is blocked for some reason
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: e05e127ba0486036ed61d6e89c4d58c119476e60
User & Date: mrwellan on 2015-07-14 15:21:32
Other Links: branch diff | manifest | tags
Context
2015-07-15
09:28
Change archiving ERROR's to WARNING's check-in: 106d429710 user: mrwellan tags: v1.60
2015-07-14
15:21
Improved feedback when archiving is blocked for some reason check-in: e05e127ba0 user: mrwellan tags: v1.60
14:02
Bumped version to 1.6021 check-in: bb8b165e5f user: mrwellan tags: v1.60, v1.6021
Changes

Modified archive.scm from [1e200bee3b] to [8c7a48b5ff].

143
144
145
146
147
148
149

150

151
152

153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
	      (test-base         (if (and partial-path-index 
					  test-physical-path )
				     (substring test-physical-path
						0
						partial-path-index)
				     #f)))
	 

 	 (if (or toplevel/children

		 (not (file-exists? test-path)))
	     #f

	     (begin
	       (debug:print 0
			    "From test-dat=" test-dat " derived the following:\n"
			    "test-partial-path  = " test-partial-path "\n"
			    "test-path          = " test-path "\n"
			    "test-physical-path = " test-physical-path "\n"
			    "partial-path-index = " partial-path-index "\n"
			    "test-base          = " test-base)
	       (hash-table-set! disk-groups test-base (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
	       (hash-table-set! test-groups test-base (cons test-dat (hash-table-ref/default test-groups test-base '())))
	       test-path))))
     tests)
    ;; for each disk-group
    (for-each 
     (lambda (disk-group)
       (debug:print 0 "Processing disk-group " disk-group)
       (let* ((test-paths (hash-table-ref disk-groups disk-group))
	      ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-")







>
|
>
|
<
>
|
|
|
|
|
|
|
|
|
|
|







143
144
145
146
147
148
149
150
151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
	      (test-base         (if (and partial-path-index 
					  test-physical-path )
				     (substring test-physical-path
						0
						partial-path-index)
				     #f)))
	 
 	 (cond
	  (toplevel/children
	   (debug:print 0 "ERROR: cannot archive " test-name " with id " test-id " as it is a toplevel test with children"))
	  ((not (file-exists? test-path))

	   (debug:print 0 "ERROR: Cannot archive " test-name "/" item-path " as path " test-path " does not exist"))
	  (else
	   (debug:print 0
			"From test-dat=" test-dat " derived the following:\n"
			"test-partial-path  = " test-partial-path "\n"
			"test-path          = " test-path "\n"
			"test-physical-path = " test-physical-path "\n"
			"partial-path-index = " partial-path-index "\n"
			"test-base          = " test-base)
	   (hash-table-set! disk-groups test-base (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
	   (hash-table-set! test-groups test-base (cons test-dat (hash-table-ref/default test-groups test-base '())))
	   test-path))))
     tests)
    ;; for each disk-group
    (for-each 
     (lambda (disk-group)
       (debug:print 0 "Processing disk-group " disk-group)
       (let* ((test-paths (hash-table-ref disk-groups disk-group))
	      ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-")