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 ;;======================================================================