Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -204,21 +204,21 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (cdb:remote-run db:test-set-state-status-by-id #f test-id #f #f b) + (open-run-close db:test-set-state-status-by-id #f test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (cdb:remote-run db:test-set-state-status-by-id #f test-id state #f #f) + (open-run-close db:test-set-state-status-by-id #f test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -234,11 +234,11 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (cdb:remote-run db:test-set-state-status-by-id #f test-id #f status #f) + (open-run-close db:test-set-state-status-by-id #f test-id #f status #f) (db:test-set-status! testdat status))))) btn)) (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED")))) (vector-set! *state-status* 1 (lambda (status color) @@ -254,11 +254,11 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test test-id) ;; run-id run-key origtest) - (let* ((testdat (cdb:remote-run db:get-test-info-by-id #f test-id)) + (let* ((testdat (open-run-close db:get-test-info-by-id #f test-id)) (db-path (conc *toppath* "/megatest.db")) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t) (db #f)) @@ -265,22 +265,22 @@ (if (not testdat) (begin (debug:print 0 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((run-id (if testdat (db:test-get-run_id testdat) #f)) - (keydat (if testdat (cdb:remote-run db:get-key-val-pairs #f run-id) #f)) - (rundat (if testdat (cdb:remote-run db:get-run-info #f run-id) #f)) + (keydat (if testdat (open-run-close db:get-key-val-pairs #f run-id) #f)) + (rundat (if testdat (open-run-close db:get-run-info #f run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "runname") #f)) ;(teststeps (if testdat (db:get-steps-for-test db test-id) #f)) (logfile "/this/dir/better/not/exist") (rundir logfile) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat - (let ((tm (cdb:remote-run db:testmeta-get-record #f testname))) + (let ((tm (open-run-close db:testmeta-get-record #f testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -305,11 +305,11 @@ (refreshdat (lambda () (let* ((curr-mod-time (file-modification-time db-path)) (need-update (or (and (> curr-mod-time db-mod-time) (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched request-update)) - (newtestdat (if need-update (cdb:remote-run db:get-test-info-by-id #f test-id)))) + (newtestdat (if need-update (open-run-close db:get-test-info-by-id #f test-id)))) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (open-run-close db:get-steps-for-test db test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) @@ -466,11 +466,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (cdb:remote-run db:read-test-data #f test-id "%"))) + (open-run-close db:read-test-data #f test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data))) ))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -85,21 +85,21 @@ ;; (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (cdb:remote-run db:get-keys #f)) +(define *keys* (open-run-close db:get-keys #f)) ;; (define *keys* (db:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) (define *header* #f) (define *allruns* '()) (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%")) +(define *tot-run-count* (open-run-close db:get-num-runs #f "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) (define *last-update* (current-seconds)) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) @@ -163,11 +163,11 @@ (begin (debug:print-info 4 "update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " keypatts: " keypatts) (set! *please-update-buttons* #t) (set! *last-db-update-time* modtime) (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (let* ((allruns (open-run-close db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -179,13 +179,13 @@ (begin (set! *last-update* (current-seconds)) (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt)))) (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (cdb:remote-run db:get-tests-for-run #f run-id testnamepatt states statuses))) + (tests (let ((tsts (open-run-close db:get-tests-for-run #f run-id testnamepatt states statuses))) (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (cdb:remote-run db:get-key-vals #f run-id))) + (key-vals (open-run-close db:get-key-vals #f run-id))) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set (not (null? tests))) (set! result (cons (vector run tests key-vals) result))))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -944,11 +944,12 @@ res))) (define db:get-test-info-by-id db:get-test-info-not-cached-by-id) (define (db:get-test-info db run-id testname item-path) - (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) + (let ((test-id (db:get-test-id db run-id testname item-path))) + (db:get-test-info-by-id db test-id))) (define (db:test-set-comment db test-id comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -187,12 +187,13 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - - (cdb:remote-run db:teststep-set-status! #f test-id stepname "start" "-" #f #f) + (mutex-lock! m) + (db:teststep-set-status! test-id stepname "start" "-" #f #f) + (mutex-unlock! m) ;; 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) @@ -206,13 +207,18 @@ (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) - (cdb:remote-run db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) + (mutex-lock! m) + (db:teststep-set-status! test-id stepname "end" exinfo #f logfna) + (mutex-unlock! m)) (if logpro-used - (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) + (begin + (mutex-lock! m) + (cdb:test-set-log! #f test-id (conc stepname ".html")) + (mutex-unlock! m))) ;; 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))) @@ -226,10 +232,11 @@ (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail)))) (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) + (mutex-lock! m) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood (tests:test-set-status! test-id "RUNNING" "WARN" @@ -238,11 +245,12 @@ ((pass) (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) - )))) + )) + (mutex-unlock! m))) (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)))))))) (monitorjob (lambda () @@ -254,12 +262,14 @@ (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin + (mutex-lock! m) (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) (open-run-close test-set-meta-info #f test-id run-id test-name itemdat minutes) + (mutex-unlock! m) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) @@ -295,11 +305,11 @@ (thread-start! th1) (thread-start! th2) (thread-join! th2) (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* 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))) ;; Am I completed? (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) (tests:test-set-status! test-id @@ -433,11 +443,11 @@ ;; again. ;; NB - This is not working right - some top tests are not getting the path set!!! (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path)) + (let* ((testinfo (open-run-close db:get-test-info-by-id #f test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path) (if (or (not curr-test-path) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -702,11 +702,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - (open-run-close db:teststep-set-status! db test-id step state status (args:get-arg "-m") logfile) + (db:teststep-set-status! test-id step state status (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) @@ -772,11 +772,11 @@ (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (open-run-close db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile) + (db:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) @@ -791,11 +791,11 @@ (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (cdb:test-set-log! *runremote* test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - (open-run-close db:teststep-set-status! db test-id stepname "end" exitstat msg logfile)) + (db:teststep-set-status! test-id stepname "end" exitstat 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")) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -201,11 +201,11 @@ (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL (waived (if (equal? status "FAIL") - (let ((prev-test (open-run-close test:get-previous-test-run-record db run-id test-name item-path))) + (let ((prev-test (cdb:run-remote test:get-previous-test-run-record #f run-id test-name item-path))) (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) (prev-comment (db:test-get-comment prev-test))) (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)