Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -75,11 +75,12 @@ -version : print megatest version (currently " megatest-version ") Launching and managing runs -run : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt - Optionally use :state and :status + Optionally use :state and :status, use -keep-records to remove only + the run data. -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a and then run the specified testpatt with -preclean -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean @@ -340,10 +341,11 @@ "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests, respects -testpatt, defaults to % "-run" ;; alias for -runall "-remove-runs" + "-keep-records" ;; use with -remove-runs to remove only the run data "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" "-create-megatest-area" @@ -963,11 +965,11 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on action) +(define (operate-on action #!key (mode #f)) ;; #f is "use default" (let* ((runrec (runs:runrec-make-record)) (target (common:args-get-target))) (cond ((not target) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg") @@ -992,19 +994,22 @@ target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") state: (common:args-get-state) status: (common:args-get-status) - new-state-status: (args:get-arg "-set-state-status")))) + new-state-status: (args:get-arg "-set-state-status") + mode: mode))) (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" (lambda (target runname keys keyvals) - (operate-on 'remove-runs)))) + (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records") + 'remove-data-only + 'remove-all))))) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1749,11 +1749,11 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '())) (common:clear-caches) ;; clear all caches (let* ((db #f) ;; (tdbdat (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) @@ -1761,11 +1761,12 @@ (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) - (bup-mutex (make-mutex))) + (bup-mutex (make-mutex)) + (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (let* ((write-access-actions '(remove-runs set-state-status archive run-wait)) (dbfile (conc *toppath* "/megatest.db")) (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode @@ -1937,13 +1938,15 @@ (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (rmt:delete-run run-id) - (rmt:delete-old-deleted-test-records) - ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) + (if (not keep-records) + (begin + (rmt:delete-run run-id) + (rmt:delete-old-deleted-test-records))) + ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 *default-log-port* "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) @@ -1957,12 +1960,13 @@ (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (common:file-exists? run-dir) ;; (resolve-pathname run-dir) (common:nice-path run-dir) - #f))) - (case mode + #f)) + (clean-mode (or mode 'remove-all))) + (case clean-mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir @@ -1994,11 +1998,11 @@ (not (member run-dir (list "n/a" "/tmp/badname")))) (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record - (case mode + (case clean-mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) ;;======================================================================