Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -430,17 +430,18 @@ ;;====================================================================== ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok -(define (db:get-tests-for-run db run-id testpatt itempatt states statuses) +;; not-in #t = above behaviour, #f = must match +(define (db:get-tests-for-run db run-id testpatt itempatt states statuses #!key (not-in #t)) (let* ((res '()) (states-str (conc "('" (string-intersperse states "','") "')")) (statuses-str (conc "('" (string-intersperse statuses "','") "')")) (qry (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " - " AND NOT (state in " states-str " AND status IN " statuses-str ") " + " AND " (if not-in "NOT" "") " (state in " states-str " AND status IN " statuses-str ") " ;; " ORDER BY id DESC;" " ORDER BY event_time ASC;" ;; POTENTIAL ISSUE! CHECK ME! Does anyting depend on this being sorted by id? ))) (debug:print 8 "INFO: db:get-tests-for-run qry=" qry) (sqlite3:for-each-row @@ -1208,17 +1209,17 @@ (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:get-runs host port) runnamepatt numruns startrunoffset keypatts)) (db:get-runs db runnamepatt numruns startrunoffset keypatts))) -(define (rdb:get-tests-for-run db run-id testpatt itempatt states statuses) +(define (rdb:get-tests-for-run db run-id testpatt itempatt states statuses #!key (not-in #t)) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:get-tests-for-run host port) - run-id testpatt itempatt states statuses)) - (db:get-tests-for-run db run-id testpatt itempatt states statuses))) + run-id testpatt itempatt states statuses not-in: not-in)) + (db:get-tests-for-run db run-id testpatt itempatt states statuses not-in: not-in))) (define (rdb:get-test-data-by-id db test-id) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -255,11 +255,13 @@ (exit 1)) ;; put test parameters into convenient variables (runs:remove-runs db (args:get-arg ":runname") (args:get-arg "-testpatt") - (args:get-arg "-itempatt"))) + (args:get-arg "-itempatt") + state: (args:get-arg ":state") + status: (args:get-arg ":status"))) (sqlite3:finalize! db) (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -493,92 +493,93 @@ (conc "/" (string-intersperse (take dparts (- (length dparts) count)) "/")))) ;; Remove runs ;; fields are passing in through -(define (runs:remove-runs db runnamepatt testpatt itempatt) +(define (runs:remove-runs db runnamepatt testpatt itempatt #!key (state #f)(status #f)) (let* ((keys (rdb:get-keys db)) (rundat (runs:get-runs-by-patt db keys runnamepatt)) (header (vector-ref rundat 0)) - (runs (vector-ref rundat 1))) + (runs (vector-ref rundat 1)) + (states (if state (string-split state ",") '())) + (statuses (if status (string-split status ",") '()))) (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")) (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 '() '()) + (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt states statuses not-in: #f) '())) (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)))) - )))) - )))) + + (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 ;;======================================================================