Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -89,10 +89,12 @@
-rerun FAIL,WARN... : re-run if called on a test that previously ran (nullified
if -keepgoing is also specified)
-rebuild-db : bring the database schema up to date
-rollup : fill run (set by :runname) with latest test(s) from
prior runs with same keys
+ -lock : lock the run specified by target and runname as locked
+ which prevents -remove-runs from removing the run
-update-meta : update the tests metadata for all tests
-env2file fname : write the environment to fname.csh and fname.sh
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-archive : archive tests, use -target, :runname, -itempatt and -testpatt
@@ -176,10 +178,11 @@
"-summarize-items"
"-gui"
;; misc
"-archive"
"-repl"
+ "-lock"
;; queries
"-test-paths" ;; get path(s) to a test, ordered by youngest first
"-runall" ;; run all tests
"-remove-runs"
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -504,77 +504,81 @@
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
(dirs-to-remove (make-hash-table)))
- (let* ((run-id (db:get-value-by-header run header "id") )
- (tests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
- (lasttpath "/does/not/exist/I/hope"))
-
- (if (not (null? tests))
- (begin
- (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
- (for-each
- (lambda (test)
- (let* ((item-path (db:test-get-item-path test))
- (test-name (db:test-get-testname test))
- (run-dir (db:test-get-rundir test)))
- (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
- (rdb:delete-test-records db (db:test-get-id test))
- (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
- (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
- (set! lasttpath fullpath)
- (hash-table-set! dirs-to-remove fullpath #t)
- ;; The following was the safe delete code but it was not being exectuted.
- ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
- ;; (dir-to-rem (get-dir-up-n fullpath dirs-count))
- ;; (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
- ;; (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
- ;; (if (file-exists? fullpath)
- ;; (begin
- ;; (debug:print 1 cmd)
- ;; (system cmd)))
- ;; ))
- ))))
- tests)))
-
- ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records
- ;; for each test in case we get killed. That should minimize the detritus left on disk
- ;; process the dirs from longest string length to shortest
- (for-each
- (lambda (dir-to-remove)
- (if (file-exists? dir-to-remove)
- (let ((dir-in-db '()))
- (sqlite3:for-each-row
- (lambda (dir)
- (set! dir-in-db (cons dir dir-in-db)))
- db "SELECT rundir FROM tests WHERE rundir LIKE ?;"
- (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db
- (if (null? dir-in-db)
- (begin
- (debug:print 2 "Removing directory with zero db references: " dir-to-remove)
- (system (conc "rm -rf " dir-to-remove))
- (hash-table-delete! dirs-to-remove dir-to-remove))
- (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
- (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))
-
- ;; remove the run if zero tests remain
- (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
- (if (null? remtests) ;; no more tests remaining
- (let* ((dparts (string-split lasttpath "/"))
- (runpath (conc "/" (string-intersperse
- (take dparts (- (length dparts) 1))
- "/"))))
- (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
- (db:delete-run db run-id)
- ;; need to figure out the path to the run dir and remove it if empty
- ;; (if (null? (glob (conc runpath "/*")))
- ;; (begin
- ;; (debug:print 1 "Removing run dir " runpath)
- ;; (system (conc "rmdir -p " runpath))))
- ))))
- ))
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (run-state (db:get-value-by-header run header "state"))
+ (tests (if (not (equal? run-state "locked"))
+ (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '())
+ '()))
+ (lasttpath "/does/not/exist/I/hope"))
+ (if (not (equal? run-state "locked"))
+ (begin
+ (if (not (null? tests))
+ (begin
+ (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
+ (for-each
+ (lambda (test)
+ (let* ((item-path (db:test-get-item-path test))
+ (test-name (db:test-get-testname test))
+ (run-dir (db:test-get-rundir test)))
+ (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
+ (rdb:delete-test-records db (db:test-get-id test))
+ (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
+ (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
+ (set! lasttpath fullpath)
+ (hash-table-set! dirs-to-remove fullpath #t)
+ ;; The following was the safe delete code but it was not being exectuted.
+ ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
+ ;; (dir-to-rem (get-dir-up-n fullpath dirs-count))
+ ;; (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
+ ;; (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
+ ;; (if (file-exists? fullpath)
+ ;; (begin
+ ;; (debug:print 1 cmd)
+ ;; (system cmd)))
+ ;; ))
+ ))))
+ tests)))
+
+ ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records
+ ;; for each test in case we get killed. That should minimize the detritus left on disk
+ ;; process the dirs from longest string length to shortest
+ (for-each
+ (lambda (dir-to-remove)
+ (if (file-exists? dir-to-remove)
+ (let ((dir-in-db '()))
+ (sqlite3:for-each-row
+ (lambda (dir)
+ (set! dir-in-db (cons dir dir-in-db)))
+ db "SELECT rundir FROM tests WHERE rundir LIKE ?;"
+ (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db
+ (if (null? dir-in-db)
+ (begin
+ (debug:print 2 "Removing directory with zero db references: " dir-to-remove)
+ (system (conc "rm -rf " dir-to-remove))
+ (hash-table-delete! dirs-to-remove dir-to-remove))
+ (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
+ (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))
+
+ ;; remove the run if zero tests remain
+ (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
+ (if (null? remtests) ;; no more tests remaining
+ (let* ((dparts (string-split lasttpath "/"))
+ (runpath (conc "/" (string-intersperse
+ (take dparts (- (length dparts) 1))
+ "/"))))
+ (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
+ (db:delete-run db run-id)
+ ;; need to figure out the path to the run dir and remove it if empty
+ ;; (if (null? (glob (conc runpath "/*")))
+ ;; (begin
+ ;; (debug:print 1 "Removing run dir " runpath)
+ ;; (system (conc "rmdir -p " runpath))))
+ ))))
+ ))))
runs)))
;;======================================================================
;; Routines for manipulating runs
;;======================================================================