Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -51,10 +51,16 @@ ;; (begin ;; (debug:print 4 "INFO: Turning off pragma synchronous") ;; (sqlite3:execute db "PRAGMA synchronous = 0;")) ;; (debug:print 4 "INFO: NOT turning off pragma synchronous")) db)) + +(define (open-run-close proc idb . params) + (let* ((db (if idb idb (open-db))) + (res (apply proc db params))) + (if (not idb)(sqlite3:finalize! db)) + res)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) @@ -1026,11 +1032,11 @@ (if tdb (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - db + tdb "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (sqlite3:finalize! tdb) (reverse res)) '()))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -63,12 +63,10 @@ (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (if runscript (conc testpath "/" runscript) #f)) - (db #f) - (tdb #f) (rollup-status 0)) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config @@ -96,30 +94,22 @@ (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) - ;; now can find our db - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - ;; (set! *cache-on* #t) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + + (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (change-directory work-area) - (on-exit (lambda () - (debug:print 0 "Finalizing db!!!") - (sqlite3:finalize! db))) - - (set-run-config-vars db run-id) + (open-run-close set-run-config-vars #f run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (set-megatest-env-vars db run-id) + (open-run-close set-megatest-env-vars #f run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") - (test-set-meta-info db test-id run-id test-name itemdat) - (test-set-status! db test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + (open-run-close test-set-meta-info #f test-id run-id test-name itemdat) + (open-run-close 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 @@ -155,14 +145,11 @@ ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? - (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) - (db (open-db))) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) @@ -192,11 +179,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rdb:teststep-set-status! db test-id stepname "start" "-" itemdat #f #f) + (open-run-close db:teststep-set-status! #f test-id stepname "start" "-" itemdat #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -210,13 +197,13 @@ (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (rdb:teststep-set-status! db test-id stepname "end" exinfo itemdat #f logfna)) + (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo itemdat #f logfna)) (if logpro-used - (rdb:test-set-log! db test-id (conc stepname ".html"))) + (open-run-close db:test-set-log! #f test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -234,18 +221,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 - (test-set-status! db test-id "RUNNING" "WARN" + (open-run-close test-set-status! #f test-id "RUNNING" "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (test-set-status! db test-id "RUNNING" "PASS" #f #f)) + (open-run-close test-set-status! #f test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail - (test-set-status! db test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (open-run-close 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)))))))) @@ -266,12 +253,12 @@ (begin ;; (if (not (args:get-arg "-server")) ;; (server:client-setup db)) ;; (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) ;; (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) - (set! kill-job? (test-get-kill-request db test-id)) ;; run-id test-name itemdat)) - (test-set-meta-info db test-id run-id test-name itemdat minutes: minutes) + (set! kill-job? (open-run-close test-get-kill-request #f test-id)) ;; run-id test-name itemdat)) + (open-run-close test-set-meta-info #f test-id run-id test-name itemdat minutes: minutes) ;; (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) @@ -291,13 +278,12 @@ (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") - (test-set-status! db test-id "KILLED" "FAIL" + (open-run-close test-set-status! #f test-id "KILLED" "FAIL" (args:get-arg "-m") #f) - (sqlite3:finalize! db) (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) @@ -312,15 +298,15 @@ (mutex-lock! m) ;; (set! db (open-db)) ;; (if (not (args:get-arg "-server")) ;; (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) - (testinfo (db:get-test-info-by-id db test-id))) ;; )) ;; run-id test-name item-path))) + (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) - (test-set-status! db test-id + (open-run-close 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 @@ -339,11 +325,11 @@ (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")) (args:get-arg "-m") #f))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items db run-id test-name #f)) ;; don't force - just update if no + (open-run-close tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no ) (mutex-unlock! m) ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -61,11 +61,10 @@ (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) - (define (set-megatest-env-vars db run-id) (let ((keys (rdb:get-keys db))) (for-each (lambda (key) (sqlite3:for-each-row Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -54,10 +54,14 @@ (test "register-test, test info" "NOT_STARTED" (begin (tests:register-test *db* 1 "nada" "") (vector-ref (db:get-test-info *db* 1 "nada" "") 3))) +(test #f "NOT_STARTED" + (begin + (open-run-close tests:register-test #f 1 "nada" "") + (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))) (test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) (define remargs (args:get-args '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada")