Overview
| Comment: | Reworked remove runs to only delete directories no longer referenced in the database |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | rollup |
| Files: | files | file ages | folders |
| SHA1: |
2961a06589ab18db9f98c52a48be0780 |
| User & Date: | matt on 2011-09-05 16:22:20 |
| Other Links: | branch diff | manifest | tags |
Context
|
2011-09-05
| ||
| 17:10 | Polished the rollup and remove code a bit Closed-Leaf check-in: be2cae83a5 user: matt tags: rollup (unpublished) | |
| 16:22 | Reworked remove runs to only delete directories no longer referenced in the database check-in: 2961a06589 user: matt tags: rollup (unpublished) | |
|
2011-09-04
| ||
| 20:12 | Added rollup. check-in: bf70f7cd40 user: matt tags: rollup (unpublished) | |
Changes
Modified runs.scm from [f3e89435b8] to [e847609f7b].
| ︙ | ︙ | |||
713 714 715 716 717 718 719 |
(rundat (runs:get-runs-by-patt db keys runnamepatt))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1)))
(debug:print 1 "Header: " header)
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
| | > > | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > | 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 |
(rundat (runs:get-runs-by-patt db keys runnamepatt))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1)))
(debug:print 1 "Header: " header)
(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 (db-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)
(db: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 (db-get-tests-for-run db (db:get-value-by-header run header "id"))))
(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"))
|
| ︙ | ︙ |