Megatest

Diff
Login

Differences From Artifact [8801ee7227]:

To Artifact [7187084d9f]:


254
255
256
257
258
259
260

261

262
263
264
265
266















267
268
269
270
271
272
273
254
255
256
257
258
259
260
261

262





263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284







+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    ;; (sqlite3:finalize! db) 
    ;; now add non-directly referenced dependencies (i.e. waiton)
    (if (not (null? test-names))
	(let loop ((hed (car test-names))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	  (debug:print-info 4 "hed=" hed " at top of loop")
	  (let* ((config  (tests:get-testconfig hed 'return-procs))
		 (waitons (let ((instr (if config 
		 (waitons (if config (string-split (let ((w (config-lookup config "requirements" "waiton")))
					   (config-lookup config "requirements" "waiton")
						     (if w w "")))
			      (begin
				(debug:print 0 "ERROR: non-existent required test \"" hed "\"")
                                (if db (sqlite3:finalize! db))
				(exit 1)))))
					   (begin ;; No config means this is a non-existant test
					     (debug:print 0 "ERROR: non-existent required test \"" hed "\"")
					     (if db (sqlite3:finalize! db))
					     (exit 1)))))
			    (debug:print-info 8 "waitons string is " instr)
			    (string-split (cond
					   ((procedure? instr)
					    (let ((res (instr)))
					      (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
					      res))
					   ((string? instr)     instr)
					   (else 
					    ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
					    ""))))))
	    (debug:print-info 8 "waitons: " waitons)
	    ;; check for hed in waitons => this would be circular, remove it and issue an
	    ;; error
	    (if (member hed waitons)
		(begin
		  (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		  (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
	    
815
816
817
818
819
820
821



822

823
824
825



826

827
828
829
830
831
832
833
826
827
828
829
830
831
832
833
834
835

836
837
838
839
840
841
842

843
844
845
846
847
848
849
850







+
+
+
-
+



+
+
+
-
+







				   (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable")))
			     (if real-dir 
				 (debug:print 0 "WARNING: directory " real-dir " does not exist")
				 (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
			 (if (symbolic-link? run-dir)
			     (begin
			       (debug:print-info 1 "Removing symlink " run-dir)
			       (handle-exceptions
				exn
				(debug:print 0 "ERROR:  Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
			       (delete-file run-dir))
				(delete-file run-dir)))
			     (if (directory? run-dir)
				 (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
				     (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty")
				      (handle-exceptions
				       exn
				       (debug:print 0 "ERROR:  Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
				     (delete-directory run-dir)) ;; it should be empty by here BUG BUG, add error catch
				       (delete-directory run-dir)))
				 (if run-dir
				     (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
				     (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
				 )))
			((set-state-status)
			 (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status))
			 (open-run-close db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f)))))