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 ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,14 +1,14 @@ # run some tests BINPATH=$(shell realpath ../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) -RUNNAME := $(shell date +w%V.%u.%H) +RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" # Set SERVER to "-server -" -SERVER := "" +SERVER := runall : test1 test2 test1 : cleanprep $(MEGATEST) -runtests ez_pass -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_a $(SERVER) @@ -17,22 +17,20 @@ $(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b $(SERVER) -debug 10 test3 : cleanprep $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) +test4 : cleanprep + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) >& aa.log & + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) >& ab.log & + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) >& ac.log & + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ad -v $(SERVER) >& ad.log & + cleanprep : ../*.scm sqlite3 megatest.db "delete from metadat where var='SERVER';" mkdir -p /tmp/mt_runs /tmp/mt_links - cd ..;make - @sleep 1 - # @if ps -def |awk '{print $8}'|grep megatest; then \ - # echo WARNING: These tests will kill megatest and dashboard!; \ - # sleep 3; \ - # killall -9 dboard || true; \ - # killall -9 megatest || true; \ - # fi - cd ../;make install + cd ..;make install $(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt % -itempatt % $(BINPATH)/dboard -rows 15 & touch cleanprep test : ADDED utils/cleanup-links-dir.sh Index: utils/cleanup-links-dir.sh ================================================================== --- /dev/null +++ utils/cleanup-links-dir.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +export LINKSDIR=$1 +export RUNSDIR=$2 + +if [ "x$LINKSDIR" == "x" ];then + echo Usage: cleanup-links-dir /links/dir/path /runs/dir/path + exit +fi + + +echo Removing dangling links.... +for lnk in `find $LINKSDIR -type l ! -exec test -r {} \; -print`; do + echo $lnk + rm -f $lnk +done + +echo Removing empty directories.... +find $LINKSDIR -depth -type d -empty -print -exec rmdir {} \;