Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -81,15 +81,14 @@ -test-paths targpatt : get the most recent test path(s) matching targpatt e.g. %/%... returns list sorted by age ascending, see examples below Misc -force : override some checks - -remove-runs : remove the data for a run, requires all fields be specified - and :runname ,-testpatt and -itempatt - and -testpatt - -rerun FAIL,WARN... : re-run if called on a test that previously ran (nullified - if -keepgoing is also specified) + -remove-runs : remove the data for a run, requires :runname, -testpatt and + -itempatt be set. Optionally use :state and :status + -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs + -rerun FAIL,WARN... : re-run if called on a test that previously ran -rebuild-db : bring the database schema up to date -rollup : fill run (set by :runname) with latest test(s) from prior runs with same keys -lock : lock the run specified by target and runname as locked which prevents -remove-runs from removing the run @@ -163,10 +162,11 @@ "-server" "-extract-ods" "-pathmod" "-env2file" "-setvars" + "-set-state-status" "-debug" ;; for *verbosity* > 2 "-override-timeout" ) (list "-h" "-force" @@ -184,11 +184,10 @@ ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" - "-keepgoing" "-usequeue" "-rebuild-db" "-rollup" "-update-meta" @@ -228,49 +227,51 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (remove-runs) +(define (operate-on db action) (cond ((not (args:get-arg ":runname")) - (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the run name pattern with :runname patt") + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") (exit 2)) ((not (args:get-arg "-testpatt")) - (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the test pattern with -testpatt") + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) ((not (args:get-arg "-itempatt")) - (print "ERROR: Missing required parameter for -remove-runs, you must specify the items with -itempatt") + (print "ERROR: Missing required parameter for " action ", you must specify the items with -itempatt") (exit 4)) - ((let ((db #f)) - (if (not (setup-for-run)) - (begin - (debug:print 0 print "Failed to setup, exiting") - (exit 1))) - (set! db (open-db)) -;; (if (not (args:get-arg "-server")) -;; (server:client-setup db)) - (if (not (car *configinfo*)) - (begin - (debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found") - (exit 1)) - ;; put test parameters into convenient variables - (runs:remove-runs db - (args:get-arg ":runname") - (args:get-arg "-testpatt") - (args:get-arg "-itempatt") - state: (args:get-arg ":state") - status: (args:get-arg ":status"))) - (sqlite3:finalize! db) - (set! *didsomething* #t))))) + (else + (if (not (car *configinfo*)) + (begin + (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (runs:operate-on db + action + (args:get-arg ":runname") + (args:get-arg "-testpatt") + (args:get-arg "-itempatt") + state: (args:get-arg ":state") + status: (args:get-arg ":status") + new-state-status: (args:get-arg "-set-state-status"))) + (sqlite3:finalize! db) + (set! *didsomething* #t)))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" (lambda (db target runname keys keynames keyvallst) - (remove-runs)))) + (operate-on db 'remove-runs)))) + +(if (args:get-arg "-set-state-status") + (general-run-call + "-set-state-status" + "set state and status" + (lambda (db target runname keys keynames keyvallst) + (operate-on db 'set-state-status)))) ;;====================================================================== ;; Query runs ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -496,18 +496,22 @@ (conc "/" (string-intersperse (take dparts (- (length dparts) count)) "/")))) ;; Remove runs ;; fields are passing in through -(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)) - (states (if state (string-split state ",") '())) - (statuses (if status (string-split status ",") '()))) - (debug:print 1 "Header: " header) +;; action: +;; 'remove-runs +;; 'set-state-status +(define (runs:operate-on db action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-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)) + (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)))) + (debug:print 2 "Header: " header " action: " action " new-state-status: " new-state-status) (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))) @@ -518,70 +522,83 @@ '())) (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")) + (case action + ((remove-runs) + (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + ((set-state-status) + (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + (else + (print "INFO: action not recognised " action))) (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))) + (case action + ((remove-runs) + (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))) + ;; )) + ))) + ((set-state-status) + (debug:print 4 "INFO: new state " (car state-status) ", new status " (cadr state-status)) + (db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) + 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))))) + (if (eq? action 'remove-runs) + (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 (eq? action 'remove-runs) + (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 Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -18,14 +18,14 @@ test3 : cleanprep $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) test4 : cleanprep - $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) >& aa.log & - $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) >& ab.log & - $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) >& ac.log & - $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ad -v $(SERVER) >& ad.log & + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) 2&>1 aa.log & + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) 2&>1 ab.log & + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) 2&>1 ac.log & + $(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ad -v $(SERVER) 2&>1 ad.log & $(MEGATEST) -runtests runfirst -itempatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v $(MEGATEST) -runtests runfirst -itempatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cleanprep : ../*.scm Makefile *.config sqlite3 megatest.db "delete from metadat where var='SERVER';"