1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
|
(let ((fullname (conc real-dir "/" f)))
(if (not (string-search (regexp "testdat.db") f))
(runs:recursive-delete-with-error-msg fullname)))
(+ 1 x))
0 real-dir)
;; then the entire directory
(runs:recursive-delete-with-error-msg real-dir))
;; Remove runs
;; fields are passing in through
;; action:
;; 'remove-runs
;; 'set-state-status
;;
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
|
(let ((fullname (conc real-dir "/" f)))
(if (not (string-search (regexp "testdat.db") f))
(runs:recursive-delete-with-error-msg fullname)))
(+ 1 x))
0 real-dir)
;; then the entire directory
(runs:recursive-delete-with-error-msg real-dir))
;; cleanup often needs to remove all but the last N runs per target
;;
;; target-patts a1/b1/c1,a2/b2/c2 ...
;;
;; This will fail if called with empty target or a bad target (i.e. missing or extra fields)
;;
(define (runs:get-hash-by-target target-patts runpatt)
(let* ((targets (string-split target-patts ","))
(keys (rmt:get-keys))
(res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
(for-each
(lambda (target-patt)
(let ((runs (rmt:simple-get-runs runpatt #f #f target-patt)))
(for-each
(lambda (run)
(let ((target (simple-run-target run)))
(hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '())))))
runs)))
targets)
res-ht))
;; 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))
(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))
(trim-amt (- len num-to-keep)))
(if (> trim-amt 0)
(take sorted trim-amt)
'()))))
(hash-table-set! runs-ht target to-remove)
(print target ":")
(for-each
(lambda (run)
(let ((remove (member run to-remove (lambda (a b)
(eq? (simple-run-id a)
(simple-run-id b))))))
(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)))
;; (for-each
;; (lambda (target)
;; (let ((runs-to-remove (hash-table-ref data target )))
;; (for-each
;; (lambda (run)
;; (print "megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))
;; runs-to-remove)))
;; (hash-table-keys data))))
;; Remove runs
;; fields are passing in through
;; action:
;; 'remove-runs
;; 'set-state-status
;;
|