Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -110,10 +110,18 @@ ;;====================================================================== ;; R U N S ;;====================================================================== +(define (runs:get-std-run-fields keys remfields) + (let* ((header (append (map key:get-fieldname keys) + remfields)) + (keystr (conc (keys->keystr keys) "," + (string-intersperse remfields ",")))) + (list keystr header))) + +;; replace header and keystr with a call to runs:get-std-run-fields (define (db-get-runs db runpatt . count) (let* ((res '()) (keys (db-get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append (map key:get-fieldname keys) @@ -157,10 +165,13 @@ (vector header res))) (define (db:set-comment-for-run db run-id comment) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)) +(define (db:delete-run db run-id) + (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) + ;;====================================================================== ;; T E S T S ;;====================================================================== (define (make-db:test)(make-vector 6)) @@ -190,13 +201,19 @@ db "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 ? ORDER BY id DESC;" run-id testpatt (if itempatt itempatt "%")) res)) +;; this one is a bit broken BUG FIXME (define (db:delete-test-step-records db run-id test-name) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=?);" run-id test-name)) +;; +(define (db:delete-test-records db test-id) + (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) + (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) + (define (db:get-count-tests-running db) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -44,14 +44,17 @@ -showkeys : show the keys used in this megatest setup Misc -force : override some checks -xterm : start an xterm instead of launching the test + -remove-runs : remove the data for a run, requires fields, :runname + and -testpatt + -testpatt patt : remove tests matching patt (requires -remove-runs) Helpers - -runstep stepname ... : take leftover params as comand and execute as stepname - log will be in stepname.log + -runstep stepname ... : take remaining params as comand and execute as stepname + log will be in stepname.log. Best to put command in quotes -logpro file : with -exec apply logpro file to stepname.log, creates stepname.html and sets log to same If using make use stepname_logpro.log as your target Called as " (string-intersperse (argv) " "))) @@ -75,21 +78,20 @@ "-testpatt" "-itempatt" "-setlog" "-runstep" "-logpro" - "-remove-run" "-m" ) (list "-h" "-force" "-xterm" "-showkeys" "-test-status" "-gui" "-runall" ;; run all tests - + "-remove-runs" ) args:arg-hash 0)) (if (args:get-arg "-h") @@ -265,34 +267,40 @@ ;;====================================================================== ;; Remove old run(s) ;;====================================================================== (define (remove-runs) - (if (not (args:get-arg ":runname")) - (begin - (print "ERROR: Missing required parameter for -remove-run, you must specify the run name with :runname runname") - (exit 2)) - (let ((db #f)) - (if (not (setup-for-run)) - (begin - (print "Failed to setup, exiting") - (exit 1))) - (set! db (open-db)) - (if (not (car *configinfo*)) - (begin - (print "ERROR: Attempted to remove a test but run area config file not found") - (exit 1)) - ;; put test parameters into convenient variables - (let* ((test-names (string-split (args:get-arg "-remove-tests") ","))) - (run-tests db test-names))) - ;; run-waiting-tests db) - (sqlite3:finalize! db) - (run-waiting-tests #f) - (set! *didsomething* #t)))) - -(if (args:get-arg "-runtests") - (runtests)) + (cond + ((not (args:get-arg ":runname")) + (print "ERROR: Missing required parameter for -remove-runs, you must specify the run name pattern with :runname patt") + (exit 2)) + ((not (args:get-arg "-testpatt")) + (print "ERROR: Missing required parameter for -remove-runs, 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") + (exit 4)) + ((let ((db #f)) + (if (not (setup-for-run)) + (begin + (print "Failed to setup, exiting") + (exit 1))) + (set! db (open-db)) + (if (not (car *configinfo*)) + (begin + (print "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"))) + (sqlite3:finalize! db) + (set! *didsomething* #t))))) + +(if (args:get-arg "-remove-runs") + (remove-runs)) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -14,11 +14,11 @@ (define (register-run db keys) ;; test-name) (let* ((keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... - (keyvallst (keys->vallist keys)) + (keyvallst (keys->vallist keys)) ;; extracts the values from remainder of (argv) (runname (get-with-default ":runname" #f)) (state (get-with-default ":state" "no")) (status (get-with-default ":status" "n/a")) (allvals (append (list runname state status user) keyvallst)) (qryvals (append (list runname) keyvallst)) @@ -41,10 +41,42 @@ res) (begin (print "ERROR: Called without all necessary keys") #f)))) +;; runs:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) +;; to extract info from the structure returned +;; +(define (runs:get-runs-by-patt db keys runnamepatt) ;; test-name) + (let* ((keyvallst (keys->vallist keys)) + (tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) + (keystr (car tmp)) + (header (cadr tmp)) + (res '()) + (key-patt "")) + (for-each (lambda (keyval) + (let* ((key (vector-ref keyval 0)) + (fulkey (conc ":" key)) + (patt (args:get-arg fulkey))) + (if patt + (set! key-patt (conc key-patt " AND " key " like '" patt "'")) + (begin + (print "ERROR: searching for runs with no pattern set for " fulkey) + (exit 6))))) + keys) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + db + (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") + runnamepatt) + (vector header res))) + (define (register-test db run-id test-name item-path) (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path) VALUES (?,?,strftime('%s','now'),?);" run-id test-name item-path)) (define (test-set-status! db run-id test-name state status itemdat-or-path . comment) (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))) @@ -324,6 +356,40 @@ (if (not db) (sqlite3:finalize! ldb)))) waiting-test-names) (sleep 10) ;; no point in rushing things at this stage? (loop (hash-table-keys *waiting-queue*))))))) + +;; Remove runs +;; fields are passing in through +(define (runs:remove-runs db runnamepatt testpatt itempatt) + (let* ((keys (db-get-keys db)) + (rundat (runs:get-runs-by-patt db keys runnamepatt)) + (header (vector-ref rundat 0)) + (runs (vector-ref rundat 1))) + (print "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) "/"))) + (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))) + (if (not (null? tests)) + (begin + (print "Removing tests for run: " runkey " " (db-get-value-by-header run header "runname")) + (for-each + (lambda (test) + (print " " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test)) + (db:delete-test-records db (db:test-get-id test)) + (if (> (string-length (db:test-get-rundir test)) 5) ;; bad heuristic but should prevent /tmp /home etc. + (let ((fullpath (db:test-get-rundir test))) ;; "/" (db:test-get-item-path test)))) + (print "rm -rf " fullpath) + (system (conc "rm -rf " fullpath))))) + tests) + (let ((remtests (db-get-tests-for-run db (db-get-value-by-header run header "id")))) + (if (null? remtests) ;; no more tests remaining + (begin + (print "Removing run: " runkey " " (db-get-value-by-header run header "runname")) + (db:delete-run db run-id)))) + ))))) + runs))) Index: tests/megatest.config ================================================================== --- tests/megatest.config +++ tests/megatest.config @@ -3,11 +3,11 @@ fsname TEXT datapath TEXT [setup] # exectutable /path/to/megatest -max_concurrent_jobs 5 +max_concurrent_jobs 405 runsdir /tmp/runs [jobtools] # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local Index: tests/tests/sqlitespeed/runscript.rb ================================================================== --- tests/tests/sqlitespeed/runscript.rb +++ tests/tests/sqlitespeed/runscript.rb @@ -13,11 +13,11 @@ status=false (0..num_records).each do |i| randstring="a;lskdfja;sdfj;alsdfj;aslfdj;alsfja;lsfdj;alsfja;lsjfd;lasfjl;asdfja;slfj;alsjf;asljf;alsjf;lasdjf;lasjf;lasjf;alsjf;lashflkashflkerhflkdsvnlasldhlfaldf" # status=system "sqlite3 testing.db \"insert into blah (name) values ('#{randstring}');\"" system "megatest -step testing :state wrote_junk :status #{num_records}" - sleep(1) + sleep(5) puts "i=#{i}" end if status==0 status='pass' else