Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -24,11 +24,10 @@ (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) -(declare (uses rmt)) (declare (uses ezsteps)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -133,13 +132,13 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== -(define (run-info-panel keydat testdat runname) +(define (run-info-panel db keydat testdat runname) (let* ((run-id (db:test-get-run_id testdat)) - (rundat (cdb:remote-run db:get-run-info #f run-id)) + (rundat (db:get-run-info db run-id)) (header (db:get-header rundat)) (event_time (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "event_time"))) (iup:frame @@ -214,30 +213,30 @@ (define *dashboard-test-db* #t) ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel test-id testdat #!key (db #f)) +(define (set-fields-panel db test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) (newstate #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (rmt:test-set-state-status-by-id test-id #f #f b) + (db:test-set-state-status-by-id db 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) - (rmt:test-set-state-status-by-id test-id state #f #f) + (db:test-set-state-status-by-id db test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -253,11 +252,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) - (rmt:test-set-state-status-by-id test-id #f status #f) + (db:test-set-state-status-by-id db test-id #f status #f) (db:test-set-status! testdat status))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -367,11 +366,11 @@ res)) (define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f)) (if (or (not work-area) (file-exists? (conc work-area "/testdat.db"))) - (let* ((steps-data (rmt:get-steps-for-test test-id work-area)) + (let* ((steps-data (tdb:get-steps-for-test test-id work-area)) (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) @@ -398,23 +397,24 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test test-id) ;; run-id run-key origtest) - (let* ((testdat (rmt:get-test-info-by-id test-id)) + (let* ((db-path (conc *toppath* "/megatest.db")) (db (open-db)) - (testdat (open-run-close db:get-test-info-by-id db test-id)) + (tdb (tdb:open-test-db-by-test-id-local test-id)) + (testdat (db:get-test-info-by-id db test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin (debug:print 2 "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 (rmt:get-key-val-pairs run-id) #f)) - (rundat (if testdat (rmt:get-run-info run-id) #f)) + (keydat (if testdat (db:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (db:get-run-info db run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "runname") #f)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. @@ -423,11 +423,11 @@ (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (dashboard-tests:get-compressed-steps test-id work-area: rundir) '())) (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 (rmt:testmeta-get-record testname))) + (let ((tm (db:testmeta-get-record db testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -471,11 +471,11 @@ (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) - (rmt:get-test-info-by-id test-id ))))) + (db:get-test-info-by-id db test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (dashboard-tests:get-compressed-steps test-id work-area: rundir)) @@ -591,11 +591,11 @@ (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname (iup:vbox ; #:expand "YES" ;; The run and test info (iup:hbox ; #:expand "YES" - (run-info-panel keydat testdat runname) + (run-info-panel db keydat testdat runname) (test-info-panel testdat store-label widgets) (test-meta-panel testmeta store-meta)) (host-info-panel testdat store-label) ;; The controls (iup:frame #:title "Actions" @@ -609,11 +609,11 @@ (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) (apply iup:hbox (list command-text-box command-launch-button)))) - (set-fields-panel test-id testdat) + (set-fields-panel db test-id testdat) (let ((tabs (iup:tabs ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" @@ -717,11 +717,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))) - (rmt:read-test-data test-id "%"))) + (tdb:open-run-close-db-by-test-id-local test-id #f tdb:read-test-data test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -86,29 +86,29 @@ (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* #f) ;; (open-db)) - -(if (args:get-arg "-host") - (begin - (set! *runremote* (string-split (args:get-arg "-host" ":"))) - (client:launch)) - (if (not (args:get-arg "-use-server")) - (set! *transport-type* 'fs) ;; force fs access - (client:launch))) +(define *db* (open-db)) + +;; (if (args:get-arg "-host") +;; (begin +;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (if (not (args:get-arg "-use-server")) +;; (set! *transport-type* 'fs) ;; force fs access +;; (client:launch))) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (client:setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) -;; (define *keys* (open-run-close db:get-keys #f)) -(define *keys* (cdb:remote-run db:get-keys #f)) +(define *keys* (db:get-keys *db*)) +;; (define *keys* (cdb:remote-run db:get-keys #f)) ;; (define *keys* (db:get-keys *db*)) (define *dbkeys* (append *keys* (list "runname"))) (define *header* #f) @@ -118,11 +118,11 @@ (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* (db:get-num-runs *db* "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) ;; Update management ;; (define *last-update* (current-seconds)) @@ -205,11 +205,11 @@ (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) - (allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (allruns (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -224,18 +224,19 @@ ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (mt:get-tests-for-run run-id testnamepatt states statuses - not-in: *hide-not-hide* - sort-by: sort-by - sort-order: sort-order - qryvals: 'shortlist)) + (tests (db:get-tests-for-run *db* run-id testnamepatt states statuses + #f #f + *hide-not-hide* + sort-by + sort-order + 'shortlist)) ;; NOTE: bubble-up also sets the global *all-item-test-names* ;; (tests (bubble-up tmptests priority: bubble-type)) - (key-vals (cdb:remote-run db:get-key-vals #f run-id))) + (key-vals (db:get-key-vals *db* run-id))) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) @@ -558,11 +559,11 @@ (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (open-run-close db:get-targets #f)) + (db-target-dat (db:get-targets *db*)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector @@ -823,11 +824,11 @@ (iup:attribute-set! tb "VALUE" val) (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (mt:get-runs-by-patt *keys* "%" target)) + (runs-for-targ (db:get-runs-by-patt *db* *keys* "%" target #f #f)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) @@ -983,11 +984,11 @@ ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area -(define (dashboard:summary) +(define (dashboard:summary db) (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))) (iup:vbox (iup:split ;; #:value 500 (iup:frame @@ -1008,11 +1009,11 @@ ;; (iup:frame ;; #:title "Disks Areas" (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) (iup:frame #:title "Run statistics" - (dcommon:run-stats))))) + (dcommon:run-stats db))))) ;;====================================================================== ;; R U N ;;====================================================================== ;; @@ -1024,11 +1025,11 @@ #f)) (define dashboard:update-run-summary-tab #f) ;; (define (tests window-id) -(define (dashboard:one-run) +(define (dashboard:one-run db) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" @@ -1044,19 +1045,21 @@ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) (run-matrix (iup:matrix #:expand "YES")) (updater (lambda () - (let* ((runs-dat (mt:get-runs-by-patt *keys* "%" #f)) + (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (let ((tdat (mt:get-tests-for-run run-id + (tests-dat (let ((tdat (db:get-tests-for-run db run-id (hash-table-ref/default *searchpatts* "test-name" "%/%") (hash-table-keys *state-ignore-hash*) ;; '() (hash-table-keys *status-ignore-hash*) ;; '() - not-in: *hide-not-hide* - qryvals: "id,testname,item_path,state,status"))) ;; get 'em all + #f #f + *hide-not-hide* + #f #f + "id,testname,item_path,state,status"))) ;; get 'em all (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) @@ -1169,11 +1172,11 @@ ;;====================================================================== ;; R U N S ;;====================================================================== -(define (make-dashboard-buttons nruns ntests keynames) +(define (make-dashboard-buttons db nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) @@ -1243,21 +1246,21 @@ (mark-for-update) (if (eq? val 1) (hash-table-set! *status-ignore-hash* status #t) (hash-table-delete! *status-ignore-hash* status)) (set-bg-on-filter)))) - *common:std-statuses*)) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *state-ignore-hash* state #t) (hash-table-delete! *state-ignore-hash* state)) (set-bg-on-filter)))) - *common:std-states*)) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns *tot-run-count*)) (set! *start-run-offset* val) @@ -1380,13 +1383,13 @@ controls)) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (set! *please-update-buttons* #t) (set! *current-tab-number* curr)) - (dashboard:summary) + (dashboard:summary db) runs-view - (dashboard:one-run) + (dashboard:one-run db) (dashboard:run-controls) ))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") @@ -1486,11 +1489,11 @@ (if runid (begin (lambda (x) (on-exit (lambda () (if *db* (sqlite3:finalize! *db*)))) - (cdb:remote-run examine-run *db* runid))) + (examine-run *db* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") (let ((testid (string->number (args:get-arg "-test")))) @@ -1501,11 +1504,11 @@ (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) (else - (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) + (set! uidat (make-dashboard-buttons *db* *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (let ((update-is-running #f)) (mutex-lock! *update-mutex*) @@ -1520,5 +1523,6 @@ (set! *update-is-running* #f) (mutex-unlock! *update-mutex*)))) 1)))) (iup:main-loop) +(sqlite3:finalize! *db*) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -375,15 +375,15 @@ (iup:attribute-set! general-matrix "3:0" "Version") (iup:attribute-set! general-matrix "3:1" megatest-version) general-matrix)) -(define (dcommon:run-stats) +(define (dcommon:run-stats db) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () - (let* ((run-stats (mt:get-run-stats)) + (let* ((run-stats (db:get-run-stats db)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -82,21 +82,39 @@ #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) - (begin + (let ((baddb (sqlite3:open-database ":memory:"))) (debug:print-info 11 "open-test-db END (unsucessful)" work-area) - #f))) + ;; provide an in-mem db (this is dangerous!) + (tdb:testdb-initialize baddb) + baddb))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area (rmt:test-get-rundir-from-test-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) + +;; find and open the testdat.db file for an existing test +(define (tdb:open-test-db-by-test-id-local test-id #!key (work-area #f)) + (let* ((test-path (if work-area + work-area + (open-run-close db:test-get-rundir-from-test-id #f test-id)))) + (debug:print 3 "TEST PATH: " test-path) + (open-test-db test-path))) + +;; find and open the testdat.db file for an existing test +(define (tdb:open-run-close-db-by-test-id-local test-id work-area proc . params) + (let* ((test-path (if work-area + work-area + (open-run-close db:test-get-rundir-from-test-id #f test-id))) + (tdb (open-test-db test-path))) + (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") (for-each (lambda (sqlcmd) @@ -167,11 +185,11 @@ ;; T E S T D A T A ;;====================================================================== (define (tdb:csv->test-data test-id csvdata #!key (work-area #f)) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area))) + (let ((tdb (tdb:open-test-db-by-test-id-local test-id work-area: work-area))) (if (sqlite3:database? tdb) (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) @@ -225,23 +243,23 @@ (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist) (sqlite3:finalize! tdb))))) -;; get a list of test_data records matching categorypatt -(define (tdb:read-test-data test-id categorypatt #!key (work-area #f)) - (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area))) - (if (sqlite3:database? 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))) - 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)) - '()))) +;; ;; get a list of test_data records matching categorypatt +;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f)) +;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area))) +;; (if (sqlite3:database? 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))) +;; 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)) +;; '()))) ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data test-id #!key (work-area #f)) (let loop ((lin (read-line))) (if (not (eof-object? lin)) @@ -257,11 +275,11 @@ ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (tdb:test-data-rollup test-id status #!key (work-area #f)) - (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area)) + (let ((tdb (tdb:open-test-db-by-test-id-local test-id work-area: work-area)) (fail-count 0) (pass-count 0)) (if (sqlite3:database? tdb) (begin (sqlite3:for-each-row @@ -311,11 +329,11 @@ (define (tdb:step-get-time-as-string vec) (seconds->time-string (tdb:step-get-event_time vec))) ;; db-get-test-steps-for-run (define (tdb:get-steps-for-test test-id #!key (work-area #f)) - (let* ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area)) + (let* ((tdb (tdb:open-test-db-by-test-id-local test-id work-area: work-area)) (res '())) (if (sqlite3:database? tdb) (handle-exceptions exn (begin @@ -480,11 +498,11 @@ #f)) (string