Megatest

Check-in [b4cfcf101b]
Login
Overview
Comment:Cleaned up removal messages.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: b4cfcf101b0929661678ac3aa89223d745b58623
User & Date: matt on 2012-10-24 17:25:55
Other Links: manifest | tags
Context
2012-10-29
09:40
Added json to list of eggs to install in installall.sh check-in: a8d9c84248 user: mrwellan tags: trunk
2012-10-26
08:06
starting to fix/improve the monitor check-in: 92290be7f6 user: matt tags: monitor-cleanup
2012-10-24
17:25
Cleaned up removal messages. check-in: b4cfcf101b user: matt tags: trunk
12:56
bumped-version-to-v1.51 check-in: 244782c0ff user: matt tags: trunk, v1.51
Changes

Modified runs.scm from [310fe61f1f] to [b87bc4f5c0].

769
770
771
772
773
774
775
776

777
778
779
780
781
782
783
784
785
786




787
788
789
790
791
792
793
794

795


796
797
798
799
800
801
802
769
770
771
772
773
774
775

776
777
778
779
780
781
782
783
784


785
786
787
788
789
790
791
792
793
794
795
796
797

798
799
800
801
802
803
804
805
806







-
+








-
-
+
+
+
+








+
-
+
+







					  #f))
			   (test-id   (db:test-get-id test)))
		      ;;   (tdb       (db:open-test-db run-dir)))
		      (debug:print-info 4 "test=" test) ;;   " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action)
		      (case action
			((remove-runs) ;; the tdb is for future possible. 
			 (open-run-close db:delete-test-records db #f (db:test-get-id test))
			 (debug:print-info 1 "Attempting to remove dir " real-dir " and link " run-dir)
			 (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
			 (if (and real-dir 
				  (> (string-length real-dir) 5)
				  (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
			     (begin ;; let* ((realpath (resolve-pathname run-dir)))
			       (debug:print-info 1 "Recursively removing " real-dir)
			       (if (file-exists? real-dir)
				   (if (> (system (conc "rm -rf " real-dir)) 0)
				       (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))
				   (debug:print 0 "WARNING: test run dir " real-dir " appears to not exist")))
			     (debug:print 0 "WARNING: directory " real-dir " does not exist"))
				   (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)
			       (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")
				     (delete-directory run-dir)) ;; it should be empty by here BUG BUG, add error catch
				 (if run-dir
				 (debug:print 0 "ERROR: refusing to remove " run-dir " as it either doesn't exist or is not a symlink or directory")
				     (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)))))
		  (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a))
						 (dirb (db:test-get-rundir b)))
					     (if (and (string? dira)(string? dirb))