Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1797,14 +1797,14 @@ ;; T I M E A N D D A T E ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) - (let ((parts (string-split tstr)) + (let ((parts (string-split-fields "\\w+" tstr)) (time-secs 0) - ;; s=seconds, m=minutes, h=hours, d=days - (trx (regexp "(\\d+)([smhd])"))) + ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks + (trx (regexp "(\\d+)([smhdMyw])"))) (for-each (lambda (part) (let ((match (string-match trx part))) (if match (let ((val (string->number (cadr match))) (unt (caddr match))) @@ -1811,12 +1811,15 @@ (if val (set! time-secs (+ time-secs (* val (case (string->symbol unt) ((s) 1) ((m) 60) - ((h) (* 60 60)) - ((d) (* 24 60 60)) + ((h) 3600) + ((d) 86400) + ((2) 604800) + ((M) 2628000) ;; aproximately one month + ((y) 31536000) (else 0)))))))))) parts) time-secs)) (define (seconds->hr-min-sec secs) Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -613,10 +613,24 @@ [pre-launch-env-vars] [include modified.config] ------------------------------ +Managing Old Runs +----------------- + +It is often desired to keep some older runs around but this must be balanced with the costs of disk space. + +. Use -remove-keep +. Use -archive (can also be done from the -remove-keep interface) +. use -remove-runs with -keep-records + +.For each target, remove all runs but the most recent 3 if they are over 1 week old +--------------------- +# use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel. +megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'" +--------------------- Programming API --------------- These routines can be called from the megatest repl. Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -115,11 +115,15 @@ -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test -clean-cache : remove the cached megatest.config and runconfigs.config files -no-cache : do not use the cached config files. -one-pass : launch as many tests as you can but do not wait for more to be ready - -remove-keep N action : remove all but N most recent runs per target, action is; print,remove + -remove-keep N action : remove all but N most recent runs per target + * Use -actions print,remove-runs,archive to specify action to take + * Add param -age 120d,3h,20m to apply only to runs older than the + specified age + * Add -precmd to insert a wrapper command in front of the commands run Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs -testpatt patt1/patt2,patt3/... : % is wildcard @@ -295,10 +299,15 @@ "-set-state-status" ;; move runs stuff here "-remove-keep" "-set-run-status" + "-age" + "-archive" + "-actions" + "-precmd" + "-debug" ;; for *verbosity* > 2 "-create-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file @@ -308,11 +317,10 @@ "-run-id" "-ping" "-refdb2dat" "-o" "-log" - "-archive" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" @@ -1043,15 +1051,18 @@ (general-run-call "-remove-keep" "remove keep" (lambda (target runname keys keyvals) (let ((actions (map string->symbol - (if (null? remargs) - '("print") ;; default to printing the output - (string-split (car remargs) ","))))) - (runs:remove-all-but-last-n-runs-per-target target runname (string->number (args:get-arg "-remove-keep" actions: actions))))))) - + (string-split + (or (args:get-arg "-actions") + "print") + ",")))) ;; default to printing the output + (runs:remove-all-but-last-n-runs-per-target target runname + (string->number (args:get-arg "-remove-keep")) + actions: actions))))) + (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" (lambda (target runname keys keyvals) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1781,11 +1781,15 @@ ;; delete runs older than X (weeks, days, months years etc.) ;; delete redundant runs within a target - N is the input ;; delete redundant runs within a target IFF older than given date/time AND keep at least N ;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print))) - (let ((runs-ht (runs:get-hash-by-target target-patts runpatt))) + (let* ((runs-ht (runs:get-hash-by-target target-patts runpatt)) + (age (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f)) + (age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400))) + (precmd (or (args:get-arg "-precmd") ""))) + (print "Actions: " actions) (for-each (lambda (target) (let* ((runs (hash-table-ref runs-ht target)) (sorted (sort runs (lambda (a b)(> (simple-run-event_time a)(simple-run-event_time b))))) (to-remove (let* ((len (length sorted)) @@ -1798,23 +1802,27 @@ (for-each (lambda (run) (let ((remove (member run to-remove (lambda (a b) (eq? (simple-run-id a) (simple-run-id b)))))) - (for-each - (lambda (action) - (case action - ((print) - (print " " (simple-run-runname run) - " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S") - " " (if remove "REMOVE" ""))) - ((remove) - (print "megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))) - actions))) - sorted))) - ;; (print "Sorted: " (map simple-run-event_time sorted)) - ;; (print "Remove: " (map simple-run-event_time to-remove)))) + (if (and age (> (simple-run-event_time run) age-mark)) + (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age")) + (for-each + (lambda (action) + (case action + ((print) + (print " " (simple-run-runname run) + " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S") + " " (if remove "REMOVE" ""))) + ((remove-runs) + (if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))) + ((archive) + (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))))) + actions)))) + sorted))) + ;; (print "Sorted: " (map simple-run-event_time sorted)) + ;; (print "Remove: " (map simple-run-event_time to-remove)))) (hash-table-keys runs-ht)) runs-ht)) ;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep) ;; (let ((data (runs:get-all-but-most-recent-n-per-target target-patts runpatt num-to-keep)))