Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -66,26 +66,25 @@ (if (not dbexists) (db:initialize db)) (db:set-sync db) db)) +;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (let* ((db (if idb idb (open-db))) (res #f)) - (db:set-sync db) (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! db)) res)) (define (open-run-close-exception-handling proc idb . params) (let ((runner (lambda () - (let* ((db (if idb idb (open-db))) - (res #f)) - (db:set-sync db) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - res)))) + (let* ((db (if idb idb (open-db))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! db)) + res)))) (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: database probably overloaded?") (debug:print 0 " " exn) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -93,12 +93,11 @@ (begin (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) - (change-directory *toppath*) - + (change-directory *toppath*) (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (change-directory work-area) (open-run-close set-run-config-vars #f run-id) ;; environment overrides are done *before* the remaining critical envars. @@ -105,11 +104,11 @@ (alist->env-vars env-ovrd) (open-run-close set-megatest-env-vars #f run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") (open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0) - (open-run-close test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + (open-run-close tests:test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test @@ -123,11 +122,11 @@ (job-thread #f) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) - (open-run-close test-set-status! #f test-id "RUNNING" "n/a" #f #f) + (open-run-close tests:test-set-status! #f test-id "RUNNING" "n/a" #f #f) ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) (let loop ((i 0)) (let-values @@ -221,18 +220,18 @@ " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (open-run-close test-set-status! #f test-id "RUNNING" "WARN" + (open-run-close tests:test-set-status! #f test-id "RUNNING" "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (open-run-close test-set-status! #f test-id "RUNNING" "PASS" #f #f)) + (open-run-close tests:test-set-status! #f test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail - (open-run-close test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (open-run-close tests:test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -278,11 +277,11 @@ (system (conc "kill -9 " p-id)))))) (car processes)) (system (conc "kill -9 " pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") - (open-run-close test-set-status! #f test-id "KILLED" "FAIL" + (open-run-close tests:test-set-status! #f test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) @@ -302,11 +301,11 @@ (let* ((item-path (item-list->path itemdat)) (testinfo (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (open-run-close test-set-status! #f test-id + (open-run-close tests:test-set-status! #f test-id (if kill-job? "KILLED" "COMPLETED") ;; Old logic: ;; (if (vector-ref exit-info 1) ;; look at the exit-status, #t means it at least ran ;; (if (and (not kill-job?) ;; (eq? (vector-ref exit-info 2) 0)) ;; we can now use rollup-status instead @@ -584,11 +583,11 @@ (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) ;; clean out step records from previous run if they exist (debug:print 4 "INFO: FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") (open-run-close db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir - (open-run-close test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) + (open-run-close tests:test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -226,11 +226,11 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on db action) +(define (operate-on action) (cond ((not (args:get-arg ":runname")) (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")) @@ -243,34 +243,32 @@ (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 + (runs:operate-on 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) - (operate-on db 'remove-runs)))) + (lambda (target runname keys keynames keyvallst) + (operate-on '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)))) + (lambda (target runname keys keynames keyvallst) + (operate-on 'set-state-status)))) ;;====================================================================== ;; Query runs ;;====================================================================== @@ -286,10 +284,12 @@ (header (db:get-header runsdat)) (keys (db:get-keys db)) (keynames (map key:get-fieldname keys))) (if (not (args:get-arg "-server")) (server:client-setup db)) + (sqlite3:finalize! db) + (set! db #f) ;; Each run (for-each (lambda (run) (debug:print 1 "Run: " (string-intersperse (map (lambda (x) @@ -296,12 +296,12 @@ (db:get-value-by-header run header x)) keynames) "/") "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state")) - (let ((run-id (db:get-value-by-header run header "id"))) - (let ((tests (db:get-tests-for-run db run-id testpatt itempatt '() '()))) + (let ((run-id (open-run-close db:get-value-by-header run header "id"))) + (let ((tests (open-run-close db:get-tests-for-run db run-id testpatt itempatt '() '()))) ;; Each test (for-each (lambda (test) (format #t " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" @@ -322,11 +322,11 @@ "\n diskfree: " (db:test-get-diskfree test) "\n uname: " (db:test-get-uname test) "\n rundir: " (db:test-get-rundir test) ) ;; Each test - (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) + (let ((steps (open-run-close db:get-steps-for-test db (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (db:step-get-stepname step) @@ -378,17 +378,16 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") (general-run-call "-runall" "run all tests" - (lambda (db target runname keys keynames keyvallst) + (lambda (target runname keys keynames keyvallst) ;; (let ((flags (make-hash-table))) ;; (for-each (lambda (parm) ;; (hash-table-set! flags parm (args:get-arg parm))) ;; (list "-rerun" "-force" "-itempatt")) - (runs:run-tests db - target + (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) ;; ) @@ -411,13 +410,12 @@ (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" - (lambda (db target runname keys keynames keyvallst) - (runs:run-tests db - target + (lambda (target runname keys keynames keyvallst) + (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) @@ -427,13 +425,12 @@ (if (args:get-arg "-rollup") (general-run-call "-rollup" "rollup tests" - (lambda (db target runname keys keynames keyvallst) - (runs:rollup-run db - keys + (lambda (target runname keys keynames keyvallst) + (runs:rollup-run keys (keys->alist keys "na") (args:get-arg ":runname") user)))) ;;====================================================================== @@ -442,12 +439,12 @@ (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) (general-run-call (if (args:get-arg "-lock") "-lock" "-unlock") "lock/unlock tests" - (lambda (db target runname keys keynames keyvallst) - (runs:handle-locking db + (lambda (target runname keys keynames keyvallst) + (runs:handle-locking target keys (args:get-arg ":runname") (args:get-arg "-lock") (args:get-arg "-unlock") @@ -482,26 +479,30 @@ (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) - (server:client-setup db)) + (server:client-setup db) + (begin + (sqlite3:finalize! db) + (set! db #f))) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (db:get-keys db)) + (keys (open-run-close db:get-keys db)) (keynames (map key:get-fieldname keys)) - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-files" "Get paths to test" - (lambda (db target runname keys keynames keyvallst) - (let* ((itempatt (args:get-arg "-itempatt")) - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (lambda (target runname keys keynames keyvallst) + (let* ((db #f) + (itempatt (args:get-arg "-itempatt")) + (paths (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -530,28 +531,26 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (db:get-keys db)) + (keys (open-run-close db:get-keys db)) (keynames (map key:get-fieldname keys)) - (paths (db:test-get-paths-matching db keynames target))) + (paths (open-run-close db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" - (lambda (db target runname keys keynames keyvallst) - (let* ((itempatt (args:get-arg "-itempatt")) - (paths (db:test-get-paths-matching db keynames target))) + (lambda (target runname keys keynames keyvallst) + (let* ((db #f) + (itempatt (args:get-arg "-itempatt")) + (paths (open-run-close db:test-get-paths-matching db keynames target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -560,17 +559,18 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" - (lambda (db target runname keys keynames keyvallst) - (let ((outputfile (args:get-arg "-extract-ods")) + (lambda (target runname keys keynames keyvallst) + (let ((db #f) + (outputfile (args:get-arg "-extract-ods")) (runspatt (args:get-arg ":runname")) (pathmod (args:get-arg "-pathmod")) (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist) - (db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) + (open-run-close db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -610,17 +610,20 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) - (server:client-setup db)) + (server:client-setup db) + (begin + (sqlite3:finalize! db) + (set! db #f))) (if (and state status) - (db:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile) + (open-run-close db:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status (args:get-arg "-set-toplog") (args:get-arg "-test-status") @@ -649,26 +652,29 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) - (server:client-setup db)) + (server:client-setup db) + (begin + (sqlite3:finalize! db) + (set! db #f))) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: - (db:load-test-data db test-id)) + (open-run-close db:load-test-data db test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (db:test-set-log! db test-id logfname))) + (open-run-close db:test-set-log! db test-id logfname))) (if (args:get-arg "-set-toplog") - (rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) + (open-run-close tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") - (tests:summarize-items db run-id test-name #t)) ;; do force here + (open-run-close tests:summarize-items db run-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) (cmd (if (null? remargs) #f (car remargs))) @@ -681,23 +687,17 @@ (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (db:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) - ;; close the db - ;; (sqlite3:finalize! db) + (open-run-close db:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) (change-directory testpath) - ;; re-open the db - ;; (set! db (open-db)) - ;; (if (not (args:get-arg "-server")) - ;; (server:client-setup db)) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) @@ -704,19 +704,14 @@ (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (db:test-set-log! db test-id htmllogfile))) + (open-run-close db:test-set-log! db test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - (db:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile)) - ;; (sqlite3:finalize! db) - ;;(if (not (eq? exitstat 0)) - ;; (exit 254)) ;; (exit exitstat) doesn't work?!? - ;; open the db - ;; mark the end of the test - ))) + (open-run-close db:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile)) + ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) ((and (string? status) @@ -733,15 +728,15 @@ (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) (exit 6))) (let ((msg (args:get-arg "-m"))) - (rtests:test-set-status! db test-id state newstatus msg otherdata)))) - (sqlite3:finalize! db) + (open-run-close tests:test-set-status! db test-id state newstatus msg otherdata)))) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== @@ -753,14 +748,17 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) - (server:client-setup db)) - (set! keys (db:get-keys db)) + (server:client-setup db) + (begin + (sqlite3:finalize! db) + (set! db #f))) + (set! keys (open-run-close db:get-keys db)) (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 "Look at the dashboard for now") @@ -785,14 +783,11 @@ (begin (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - ;; now can find our db - (set! db (open-db)) - (patch-db db) - (sqlite3:finalize! db) + (open-run-close patch-db #f) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== @@ -804,13 +799,16 @@ (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (if (not (args:get-arg "-server")) - (server:client-setup db)) - (runs:update-all-test_meta db) - (sqlite3:finalize! db) + (server:client-setup db) + (begin + (sqlite3:finalize! db) + (set! db #f))) + (open-run-close runs:update-all-test_meta db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -181,26 +181,27 @@ (debug:print 0 "ERROR: Called without all necessary keys") #f)))) ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. ;; keyvals -(define (runs:run-tests db target runname test-patts user flags) - (let* ((keys (db:get-keys db)) +(define (runs:run-tests target runname test-patts user flags) + (let* ((db #f) + (keys (open-run-close db:get-keys db)) (keyvallst (keys:target->keyval keys target)) - (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) + (run-id (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause ;; keepgoing is the defacto modality now, will add hit-n-run a bit later ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table))) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process (if (file-exists? runconfigf) - (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") + (open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) (for-each @@ -224,15 +225,15 @@ (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - (db:delete-tests-in-state db run-id "NOT_STARTED") - (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (open-run-close db:delete-tests-in-state db run-id "NOT_STARTED") + (open-run-close db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; from here on out the db will be opened and closed on every call runs:run-tests-queue - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print 4 "INFO: hed=" hed " at top of loop") @@ -239,11 +240,11 @@ (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (if config (string-split (let ((w (config-lookup config "requirements" "waiton"))) (if w w ""))) (begin (debug:print 0 "ERROR: non-existent required test \"" hed "\"") - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (exit 1))))) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin @@ -654,11 +655,11 @@ (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) 600) ;; i.e. no update for more than 600 seconds (begin (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (open-run-close test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) + (open-run-close tests:test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) ;;====================================================================== ;; END OF NEW STUFF @@ -676,13 +677,14 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on db action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-status #f)) - (let* ((keys (db:get-keys db)) - (rundat (runs:get-runs-by-patt db keys runnamepatt)) +(define (runs:operate-on action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-status #f)) + (let* ((db #f) + (keys (open-run-close db:get-keys db)) + (rundat (open-run-close 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)))) @@ -693,11 +695,11 @@ (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")) - (db:get-tests-for-run db (db:get-value-by-header run header "id") + (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt states statuses not-in: #f sort-by: (case action ((remove-runs) 'rundir) (else 'event_time))) @@ -721,11 +723,11 @@ (test-id (db:test-get-id test))) ;; (tdb (db:open-test-db run-dir))) (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action) (case action ((remove-runs) ;; the tdb is for future possible. - (db:delete-test-records db #f (db:test-get-id test)) + (open-run-close db:delete-test-records db #f (db:test-get-id test)) (debug:print 1 "INFO: Attempting to remove dir " run-dir) (if (and (> (string-length run-dir) 5) (file-exists? run-dir)) ;; bad heuristic but should prevent /tmp /home etc. (let* ((realpath (resolve-pathname run-dir))) (debug:print 1 "INFO: Real path of is " realpath) @@ -748,22 +750,22 @@ (open-run-close db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) tests))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) - (let ((remtests (db:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '("DELETED") '("n/a") not-in: #t))) + (let ((remtests (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '("DELETED") '("n/a") not-in: #t))) (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") " and related record") - (db:delete-run db run-id) + (open-run-close db:delete-run db run-id) ;; This is a pretty good place to purge old DELETED tests - (db:delete-tests-for-run db run-id) - (db:delete-old-deleted-test-records db) - (db:set-var db "DELETED_TESTS" (current-seconds)) + (open-run-close db:delete-tests-for-run db run-id) + (open-run-close db:delete-old-deleted-test-records db) + (open-run-close db:set-var db "DELETED_TESTS" (current-seconds)) ;; 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)))) @@ -798,23 +800,26 @@ (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (args:get-arg "-server") (server:start db (args:get-arg "-server")) - (if (not (or (args:get-arg "-runall") - (args:get-arg "-runtests"))) - (server:client-setup db))) - (set! keys (db:get-keys db)) + (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers + (args:get-arg "-runtests"))) + (server:client-setup db) + (begin + (sqlite3:finalize! db) + (set! db #f)))) + (set! keys (open-run-close db:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (exit 1)))) (if (args:get-arg "-target") (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) (if (not (car *configinfo*)) (begin @@ -822,54 +827,55 @@ (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keynames (map key:get-fieldname keys)) (keyvallst (keys->vallist keys #t))) - (proc db target runname keys keynames keyvallst))) + (proc target runname keys keynames keyvallst))) (if th1 (thread-join! th1)) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))))) ;;====================================================================== ;; Lock/unlock runs ;;====================================================================== -(define (runs:handle-locking db target keys runname lock unlock user) - (let* ((rundat (runs:get-runs-by-patt db keys runname)) +(define (runs:handle-locking target keys runname lock unlock user) + (let* ((db #f) + (rundat (open-run-close runs:get-runs-by-patt db keys runname)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) - (db:lock/unlock-run db run-id lock unlock user) + (open-run-close db:lock/unlock-run db run-id lock unlock user) (debug:print 0 "INFO: Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta db test-name test-conf) - (let ((currrecord (db:testmeta-get-record db test-name))) + (let ((currrecord (open-run-close db:testmeta-get-record db test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 10 #f)) - (db:testmeta-add-record db test-name))) + (open-run-close db:testmeta-add-record db test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (db:testmeta-update-field db test-name fld val))))) + (open-run-close db:testmeta-update-field db test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (get-all-legal-tests))) @@ -878,22 +884,23 @@ (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ;; read configs with tricks turned off (i.e. no system) (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) - (runs:update-test_meta db test-name test-conf))) + ;; use the open-run-close instead of passing in db + (runs:update-test_meta #f test-name test-conf))) test-names))) ;; This could probably be refactored into one complex query ... -(define (runs:rollup-run db keys keyvallst runname user) ;; was target, now keyvallst +(define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) - (let* (; (keyvalllst (keys:target->keyval keys target)) - (new-run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) - (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) - (curr-tests (db:get-tests-for-run db new-run-id "%" "%" '() '())) + (let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target)) + (new-run-id (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user)) + (prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%")) + (curr-tests (open-run-close db:get-tests-for-run db new-run-id "%" "%" '() '())) (curr-tests-hash (make-hash-table))) - (db:update-run-event_time db new-run-id) + (open-run-close db:update-run-event_time db new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -907,33 +914,35 @@ (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (db:get-steps-for-test db (db:test-get-id testdat))) + (test-steps (open-run-close db:get-steps-for-test db (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) - (set! new-testdat (car (db:get-tests-for-run db new-run-id testname item-path '() '()))) + (set! new-testdat (car (open-run-close db:get-tests-for-run db new-run-id testname item-path '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (sqlite3:execute - db - (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " - "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") - (db:test-get-id testdat)) - ;; Now duplicate the test data - (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (sqlite3:execute - db - (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " - "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") - (db:test-get-id testdat)) + (open-run-close + (lambda () + (sqlite3:execute + db + (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " + "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") + (db:test-get-id testdat)) + ;; Now duplicate the test data + (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (sqlite3:execute + db + (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " + "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") + (db:test-get-id testdat)))) )) prev-tests))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -111,11 +111,11 @@ (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) ;; -(define (test-set-status! db test-id state status comment dat) +(define (tests:test-set-status! db test-id state status comment dat) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (db:get-test-info-by-id db test-id)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) @@ -190,11 +190,11 @@ waived) (let ((cmt (if waived waived comment))) (db:test-set-comment db test-id cmt))) )) -(define (test-set-toplog! db run-id test-name logf) +(define (tests:test-set-toplog! db run-id test-name logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" logf run-id test-name)) (define (tests:summarize-items db run-id test-name force) ;; if not force then only update the record if one of these is true: @@ -275,11 +275,11 @@ "ItemStateStatusComment" outtxt "") (release-dot-lock outputfilename))) (close-output-port oup) (change-directory orig-dir) - (test-set-toplog! db run-id test-name outputfilename) + (tests:test-set-toplog! db run-id test-name outputfilename) ))))) (define (get-all-legal-tests) (let* ((tests (glob (conc *toppath* "/tests/*"))) (res '())) @@ -453,14 +453,14 @@ (define (rtests:test-set-status! db test-id state status comment dat) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rtests:test-set-status! host port) test-id state status comment dat)) - (test-set-status! db test-id state status comment dat))) + (tests:test-set-status! db test-id state status comment dat))) (define (rtests:test-set-toplog! db run-id test-name logf) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rtests:test-set-toplog! host port) run-id test-name logf)) - (test-set-toplog! db run-id test-name logf))) + (tests:test-set-toplog! db run-id test-name logf))) Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -1,8 +1,8 @@ [setup] # exectutable /path/to/megatest -max_concurrent_jobs 50 +max_concurrent_jobs 25 linktree /tmp/mt_links [jobtools] useshell yes # ## launcher launches jobs, the job is managed on the target host