Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -106,11 +106,18 @@ (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " api:execute-requests/message: " + ((condition-property-accessor 'exn 'message "exn message null") exn) + " arguments: " + ((condition-property-accessor 'exn 'arguments "exn arguments null") exn) + " location: " + ((condition-property-accessor 'exn 'location "exn location null") exn) + + ) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -415,11 +415,11 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") + (dbstruct (make-dbr:dbstruct-wrapper path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") local: #t)) (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -90,11 +90,11 @@ (define *useserver* (or(not (args:get-arg "-use-local")) (configf:lookup *configdat* "dashboard" "use-server"))) (define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* +(define *dbstruct-local* (make-dbr:dbstruct-wrapper path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -42,15 +42,15 @@ ;; convert to -inline (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) + ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message "exn message null") exn) (if (eq? err-status 'done) default (begin - (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database @@ -105,11 +105,11 @@ (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (handle-exceptions exn (begin - (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print-call-chain (current-error-port))) (let ((res (apply proc db params))) (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) res)))) @@ -191,11 +191,11 @@ ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((local (dbr:dbstruct-local dbstruct)) (rdb (if local - (dbr:dbstruct-localdb-set! dbstruct run-id) + (dbr:dbstruct-localdb dbstruct run-id) (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb (begin @@ -281,11 +281,11 @@ ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dbstruct (make-dbr:dbstruct path: dbdir local: local))) + (dbstruct (make-dbr:dbstruct-wrapper path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; (define (db:open-megatest-db) @@ -576,11 +576,11 @@ exn (begin (mutex-unlock! *db-sync-mutex*) (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) @@ -723,11 +723,11 @@ ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) (let* ((toppath (launch:setup-for-run)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) + (dbstruct (if toppath (make-dbr:dbstruct-wrapper path: toppath) #f)) (mtdb (if toppath (db:open-megatest-db))) (allow-cleanup (if run-ids #f #t)) (run-ids (if run-ids run-ids (if toppath (begin @@ -765,31 +765,31 @@ (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) (for-each (lambda (run-id) (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (dbstruct (if toppath (make-dbr:dbstruct-wrapper path: toppath local: #t) #f))) (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; (if (member 'new2old options) - (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) + (let* ((maindb (make-dbr:dbstruct-wrapper path: toppath local: #t)) (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))) (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) (count 1) (total (length all-run-ids)) (dead-runs '())) (for-each (lambda (run-id) (debug:print 0 "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) (set! count (+ count 1)) - (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) + (let* ((fromdb (if toppath (make-dbr:dbstruct-wrapper path: toppath local: #t) #f)) (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (db:delay-if-busy frundb) ;; (db:delay-if-busy mtdb) ;; (db:clean-up frundb) (if (eq? run-id 0) @@ -841,11 +841,11 @@ (case err-status ((busy) (thread-sleep! sleep-time)) (else (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) @@ -3081,13 +3081,13 @@ ;; STEPS '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;") '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field )) - +;;BB: db:lookup-query - called by db:general-call (define (db:lookup-query qry-name) - (let ((q (alist-ref qry-name db:queries))) + (let ((q (alist-ref (if (string? qry-name) (string->symbol qry-name) qry-name) db:queries))) (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? @@ -3110,15 +3110,16 @@ (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) (define (db:general-call dbdat stmtname params) - (let ((query (let ((q (alist-ref (if (string? stmtname) - (string->symbol stmtname) - stmtname) - db:queries))) - (if q (car q) #f)))) + ;; (let ((query (let ((q (alist-ref (if (string? stmtname) + ;; (string->symbol stmtname) + ;; stmtname) + ;; db:queries))) + ;; (if q (car q) #f)))) + (let ((query (db:lookup-query stmtname))) (db:delay-if-busy dbdat) (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) #t)) ;; get a summary of state and status counts to calculate a rollup Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -16,10 +16,20 @@ ;; (use defstruct) (defstruct dbr:dbstruct main strdb path local rundb inmem mtime rtime stime inuse refdb locdbs olddb rundb-path) + +;; constructor for dbstruct +;; +(define (make-dbr:dbstruct-wrapper #!key (path #f)(local #f)) + (let ((res (make-dbr:dbstruct))) + (dbr:dbstruct-path-set! res path) + (dbr:dbstruct-local-set! res local) + (dbr:dbstruct-locdbs-set! res (make-hash-table)) + res)) + ;;; (define d1 (make-dbr:dbstruct)) ;;; (dbr:dbstruct-main d1) ==> retrive value ;;; (dbr:dbstruct-main-set! d1 'def) ==> set value ;; (define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) @@ -62,15 +72,15 @@ ;; BB: commenting out following 3 methods since they are unused ;; (define (actual-make-dbr:dbstruct #!key (path #f)(local #f)) ;; (make-dbr:dbstruct path: path local: local locdbs: (make-hash-table))) -;; (define (dbr:dbstruct-get-localdb v run-ids) -;; (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) +(define (dbr:dbstruct-localdb v run-id) + (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) -;; (define (dbr:dbstruct-set-localdb! v run-id db) -;; (hash-table-set! (dbr:dbstruct-locdbs v) run-id db)) +(define (dbr:dbstruct-localdb-set! v run-id db) + (hash-table-set! (dbr:dbstruct-locdbs v) run-id db)) (defstruct db:test id run_id testname state status event_time host cpuload diskfree uname rundir item-path run_duration final_logf comment process_id pass_count fail_count archived ) ;; BB: 16ww4.3 begin comment out Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -955,11 +955,11 @@ ;; IDEA: megatest list -runname blah% ... ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup-for-run) - (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) + (let* (;; (dbstruct (make-dbr:dbstruct-wrapper path: *toppath* local: (args:get-arg "-local"))) (runpatt (args:get-arg "-list-runs")) (testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) @@ -1486,11 +1486,11 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (let ((dbstruct (make-dbr:dbstruct-wrapper path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) @@ -1792,11 +1792,11 @@ ;; fakeout readline (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup-for-run)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) + (dbstruct (if toppath (make-dbr:dbstruct-wrapper path: toppath local: (args:get-arg "-local")) #f))) (if dbstruct (begin (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) (import extras) ;; might not be needed Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -84,11 +84,11 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* +(define *dbstruct-local* (make-dbr:dbstruct-wrapper path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -236,11 +236,11 @@ (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((dbstruct-local (if *dbstruct-db* *dbstruct-db* (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (db (make-dbr:dbstruct path: dbdir local: #t))) + (db (make-dbr:dbstruct-wrapper path: dbdir local: #t))) (set! *dbstruct-db* db) db))) (db-file-path (db:dbfile-path 0)) ;; (read-only (not (file-read-access? db-file-path))) (start (current-milliseconds)) Index: tests/unittests/dbrdbstruct.scm ================================================================== --- tests/unittests/dbrdbstruct.scm +++ tests/unittests/dbrdbstruct.scm @@ -5,13 +5,13 @@ ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) ;; BB: 2016-01-20 suspect this file is dead code -(test #f #t (dbr:dbstruct? (make-dbr:dbstruct path: "/tmp"))) +(test #f #t (dbr:dbstruct? (make-dbr:dbstruct-wrapper path: "/tmp"))) -(define dbstruct (make-dbr:dbstruct path: "/tmp")) +(define dbstruct (make-dbr:dbstruct-wrapper path: "/tmp")) (test #f #t (begin (dbr:dbstruct-main-set! dbstruct "blah") #t)) (test #f "blah" (dbr:dbstruct-main dbstruct)) (for-each (lambda (run-id) Index: tests/unittests/runs.scm ================================================================== --- tests/unittests/runs.scm +++ tests/unittests/runs.scm @@ -10,11 +10,11 @@ "n/a" "bob"))) (test #f #t (rmt:register-test 1 "nada" "")) (test #f 30001 (rmt:get-test-id 1 "nada" "")) -(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info-by-id 1 30001) 3)) ;; "nada" "") 3)) +(test #f "NOT_STARTED" (db:test-state (rmt:get-test-info-by-id 1 30001))) ;; "nada" "") 3)) (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) (test #f "key2" (vector-ref (car (vector-ref (mt:get-runs-by-patt '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))))