Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -220,20 +220,20 @@ (define *dashboard-test-db* #t) ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel db test-id testdat #!key (db #f)) +(define (set-fields-panel dbstruct run-id 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) - (db:test-set-state-status-by-id db test-id #f #f b) + (rmt:test-set-state-status-by-id run-id test-id #f #f b) ;; IDEA: Just set a variable with the proc to call? (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox @@ -240,11 +240,11 @@ (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) - (db:test-set-state-status-by-id db test-id state #f #f) + (rmt:test-set-state-status-by-id run-id 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) @@ -418,12 +418,12 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) -(define (dashboard-tests:get-compressed-steps db test-id) - (let* ((steps-data (db:get-steps-for-test db test-id)) +(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id) + (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) (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) @@ -448,38 +448,38 @@ (stringnumber (args:get-arg "-test")))) - (if (and (number? testid) - (>= testid 0)) - (examine-test testid) + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (examine-test run-id test-id) (begin - (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test")) + (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) (else (set! uidat (make-dashboard-buttons *db* *num-runs* *num-tests* *dbkeys*)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -324,88 +324,96 @@ '("tags" #f) '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) (define (db:sync-tables tbls fromdb todb) - (let ((stmts (make-hash-table)) ;; table-field => stmt - (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) - (numrecs (make-hash-table)) - (start-time (current-milliseconds)) - (tot-count 0)) - (for-each ;; table - (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (num-fields (length fields)) - (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) - (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename ";")) - (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " - " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) - (fromdat '()) - (todat (make-hash-table)) - (count 0)) - - ;; set up the field->num table - (for-each - (lambda (field) - (hash-table-set! field->num field count) - (set! count (+ count 1))) - fields) - - ;; read the source table - (sqlite3:for-each-row - (lambda (a . b) - (set! fromdat (cons (apply vector a b) fromdat))) - fromdb - full-sel) - - (debug:print 0 "INFO: found " (length fromdat) " records to sync") - - ;; read the target table - (sqlite3:for-each-row - (lambda (a . b) - (hash-table-set! todat a (apply vector a b))) - todb - full-sel) - - ;; first pass implementation, just insert all changed rows - (let ((stmth (sqlite3:prepare todb full-ins))) - (sqlite3:with-transaction - todb - (lambda () - (for-each ;; - (lambda (fromrow) - (let* ((a (vector-ref fromrow 0)) - (curr (hash-table-ref/default todat a #f)) - (same #t)) - (let loop ((i 0)) - (if (or (not curr) - (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) - (set! same #f)) - (if (and same - (< i (- num-fields 1))) - (loop (+ i 1)))) - (if (not same) - (begin - (apply sqlite3:execute stmth (vector->list fromrow)) - (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) - fromdat))) - (sqlite3:finalize! stmth)))) - tbls) - (let ((runtime (- (current-milliseconds) start-time))) - (debug:print 0 "INFO: db sync, total run time " runtime " ms") - (for-each - (lambda (dat) - (let ((tblname (car dat)) - (count (cdr dat))) - (set! tot-count (+ tot-count count)) - (if (> count 0) - (debug:print 0 (format #f " ~10a ~5a" tblname count))))) - (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) - tot-count)) + (cond + ((not fromdb) (debug:print 0 "ERROR: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 0 "ERROR: db:sync-tables called with todb missing") -2) + ((not (sqlite3:database? fromdb)) + (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + ((not (sqlite3:database? todb)) + (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) + (else + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds)) + (tot-count 0)) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (todat (make-hash-table)) + (count 0)) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; read the source table + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat))) + fromdb + full-sel) + + (debug:print 0 "INFO: found " (length fromdat) " records to sync") + + ;; read the target table + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + todb + full-sel) + + ;; first pass implementation, just insert all changed rows + (let ((stmth (sqlite3:prepare todb full-ins))) + (sqlite3:with-transaction + todb + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< i (- num-fields 1))) + (loop (+ i 1)))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) + fromdat))) + (sqlite3:finalize! stmth)))) + tbls) + (let ((runtime (- (current-milliseconds) start-time))) + (debug:print 0 "INFO: db sync, total run time " runtime " ms") + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (set! tot-count (+ tot-count count)) + (if (> count 0) + (debug:print 0 (format #f " ~10a ~5a" tblname count))))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count)))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* @@ -852,19 +860,10 @@ res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) -(define (db:get-all-run-ids db) - (let ((res '())) - (sqlite3:for-each-row - (lambda (run-id) - (set! res (cons run-id res))) - db - "SELECT DISTINCT run_id FROM tests;") - res)) - ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; @@ -948,25 +947,25 @@ (res '()) (runs-info '())) ;; First get all the runname/run-ids (sqlite3:for-each-row (lambda (run-id runname) - (set! runs-info (cons (list runname run-id) runs-info))) + (set! runs-info (cons (list run-id runname) runs-info))) (db:get-db dbstruct #f) "SELECT id,runname FROM runs;") ;; for each run get stats data (for-each (lambda (run-info) - (let ((run-name (cadr run-info)) - (run-id (car run-info))) + (let ((run-id (car run-info)) + (run-name (cadr run-info))) (sqlite3:for-each-row (lambda (state count) (if (string? state) (let* ((stateparts (string-split state "|")) (newstate (conc (car stateparts) "\n" (cadr stateparts)))) (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) - (set! res (cons (list runname newstate count) res))))) + (set! res (cons (list run-name newstate count) res))))) (db:get-db dbstruct run-id) "SELECT state||'|'||status AS s,count(id) FROM tests AS t ORDER BY s DESC;" ) ;; (set! res (reverse res)) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) @@ -1481,11 +1480,11 @@ (if comment comment "") ;; ) ;; (sdb:qry 'getid (if logfile logfile "")))) ;; ) ;; db-get-test-steps-for-run -(define (db:get-steps-for-test db run-id test-id) +(define (db:get-steps-for-test dbstruct run-id test-id) (let* ((db (db:get-db dbstruct run-id)) (res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) @@ -1492,11 +1491,11 @@ db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))) -(define (db:get-steps-data db run-id test-id) +(define (db:get-steps-data dbstruct run-id test-id) (let ((db (db:get-db dbstruct run-id)) (res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) @@ -1786,49 +1785,35 @@ sync set-verbosity killserver )) -(define (db:login db calling-path calling-version client-signature) +(define (db:login dbstruct calling-path calling-version client-signature) (if (and (equal? calling-path *toppath*) (equal? megatest-version calling-version)) (begin (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")) ;; path matches - pass! Should vet the caller at this time ... (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))) -(define (db:process-write db request-item) - (let ((stmt-key (vector-ref request-item 0)) - (query (vector-ref request-item 1)) - (params (vector-ref request-item 2)) - (queryh (sqlite3:prepare db query))) - (apply sqlite3:execute stmt params) - #f)) -;; DISABLING FOR NOW -;; DISABLING FOR NOW (define *number-of-writes* 0) -;; DISABLING FOR NOW (define *writes-total-delay* 0) -;; DISABLING FOR NOW (define *total-non-write-delay* 0) -;; DISABLING FOR NOW (define *number-non-write-queries* 0) -;; DISABLING FOR NOW -;; DISABLING FOR NOW ;; The queue is a list of vectors where the zeroth slot indicates the type of query to -;; DISABLING FOR NOW ;; apply and the second slot is the time of the query and the third entry is a list of (define (db:general-call db stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) - (if q (car q) #f)))) + (if q (car q) #f)))) (apply sqlite3:execute db query params) #t)) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this server-side ;; -(define (db:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (db:get-keys db)) +(define (db:get-previous-test-run-record dbstruct run-id test-name item-path) + (let* ((db (db:get-db dbstruct #f)) ;; + (keys (db:get-keys db)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f)) ;; first look up the key values from the run selected by run-id (sqlite3:for-each-row @@ -1862,12 +1847,13 @@ ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; -(define (db:get-matching-previous-test-run-records db run-id test-name item-path) - (let* ((keys (db:get-keys db)) +(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) + (let* ((db (db:get-db dbstruct #f)) + (keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id @@ -1889,11 +1875,11 @@ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) @@ -1942,11 +1928,11 @@ ;; update one of the testmeta fields (define (db:testmeta-update-field dbstruct testname field value) (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) -(define (db:testmeta-get-all db) +(define (db:testmeta-get-all dbstruct) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) (db:get-db dbstruct run-id) 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 db) +(define (dcommon:run-stats dbstruct) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () - (let* ((run-stats (db:get-run-stats db)) + (let* ((run-stats (db:get-run-stats dbstruct)) (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: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1336,11 +1336,11 @@ (if run-dir (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record - (rmt:delete-test-records (db:test-get-id test)) + (rmt:delete-test-records (db:test-get-run_id test)(db:test-get-id test)) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -97,22 +97,22 @@ (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)) +(define (tdb:open-test-db-by-test-id-local dbstruct run-id 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)))) + (db:test-get-rundir-from-test-id dbstruct run-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-run-close-db-by-test-id-local test-id work-area proc . params) +(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id 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))) + (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") @@ -357,14 +357,14 @@ (conc (vector-ref b 2))) #f)) (string