Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -40,11 +40,12 @@ (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold -(define *last-db-access* 0) ;; update when db is accessed via server +(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *max-cache-size* 0) (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1047,15 +1047,15 @@ (mutex-unlock! *incoming-mutex*) (if *cache-on* (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") (db:write-cached-data))) -(define (cdb:test-rollup-iterated-pass-fail test-id) - (debug:print 4 "INFO: Adding " test-id " for iterated rollup to the queue") +(define (cdb:test-rollup-test_data-pass-fail test-id) + (debug:print 4 "INFO: Adding " test-id " for test_data rollup to the queue") (mutex-lock! *incoming-mutex*) (set! *last-db-access* (current-seconds)) - (set! *incoming-data* (cons (vector 'iterated-p/f-rollup + (set! *incoming-data* (cons (vector 'test_data-pf-rollup (current-milliseconds) (list test-id test-id test-id test-id)) *incoming-data*)) (mutex-unlock! *incoming-mutex*) (if *cache-on* @@ -1100,19 +1100,20 @@ (lambda (db . params) (let ((register-test-stmt (sqlite3:prepare db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")) (state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;")) (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")) (pass-fail-counts-stmt (sqlite3:prepare db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;")) - (iterated-rollup-stmt (sqlite3:prepare db "UPDATE tests + (test_data-rollup-stmt (sqlite3:prepare db "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status END WHERE id=?;")) - (data #f)) + (data #f) + (rollups (make-hash-table))) (mutex-lock! *incoming-mutex*) (set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1))))) (set! *incoming-data* '()) (mutex-unlock! *incoming-mutex*) (if (> (length data) 0) @@ -1127,31 +1128,41 @@ (case (vector-ref entry 0) ((state-status) (apply sqlite3:execute state-status-stmt params)) ((state-status-msg) (apply sqlite3:execute state-status-msg-stmt params)) - ((iterated-p/f-rollup) - (apply sqlite3:execute iterated-rollup-stmt params)) + ((test_data-pf-rollup) + ;; (hash-table-set! rollups (car params) params)) + (apply sqlite3:execute test_data-rollup-stmt params)) ((pass-fail-counts) + (debug:print 0 "INFO: pass fail count params are " params) (apply sqlite3:execute pass-fail-counts-stmt params)) ((register-test) (apply sqlite3:execute register-test-stmt params)) (else (debug:print 0 "ERROR: Queued entry not recognised " entry))))) data))) + ;; now do any rollups + ;; (for-each + ;; (lambda (test-id) + ;; (apply sqlite3:execute test_data-rollup-stmt (hash-table-ref rollups test-id))) + ;; (hash-table-keys rollups)) (sqlite3:finalize! state-status-stmt) (sqlite3:finalize! state-status-msg-stmt) - (sqlite3:finalize! iterated-rollup-stmt) + (sqlite3:finalize! test_data-rollup-stmt) (sqlite3:finalize! pass-fail-counts-stmt) (sqlite3:finalize! register-test-stmt) - ;; (set! *last-db-access* (current-seconds)) + (let ((cache-size (length data))) + (if (> cache-size *max-cache-size*) + (set! *max-cache-size* cache-size))) )) #f)) (define cdb:flush-queue db:write-cached-data) (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) + (rdb:flush-queue) (if (and (not (equal? item-path "")) (or (equal? status "PASS") (equal? status "WARN") (equal? status "FAIL") (equal? status "WAIVED") @@ -1314,14 +1325,14 @@ ;; Now rollup the counts to the central megatest.db (rdb:pass-fail-counts test-id fail-count pass-count) ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" ;; fail-count pass-count test-id) - (thread-sleep! 0.01) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set + (thread-sleep! 10) ;; play nice with the queue by ensuring the rollup is at least 10s later than the set ;; if the test is not FAIL then set status based on the fail and pass counts. - (rdb:test-rollup-iterated-pass-fail test-id) + (rdb:test-rollup-test_data-pass-fail test-id) ;; (sqlite3:execute ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME ;; "UPDATE tests ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 ;; THEN 'FAIL' @@ -1640,16 +1651,16 @@ (print-call-chain) (cdb:test-set-status-state test-id status state msg)) ((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg))) (cdb:test-set-status-state test-id status state msg))) -(define (rdb:test-rollup-iterated-pass-fail test-id) +(define (rdb:test-rollup-test_data-pass-fail test-id) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) - ((rpc:procedure 'cdb:test-rollup-iterated-pass-fail host port) test-id)) - (cdb:test-rollup-iterated-pass-fail test-id))) + ((rpc:procedure 'cdb:test-rollup-test_data-pass-fail host port) test-id)) + (cdb:test-rollup-test_data-pass-fail test-id))) (define (rdb:pass-fail-counts test-id fail-count pass-count) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -90,14 +90,14 @@ (lambda (test-id status state msg) (debug:print 4 "INFO: Remote call of cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg) (cdb:test-set-status-state test-id status state msg))) (rpc:publish-procedure! - 'cdb:test-rollup-iterated-pass-fail + 'cdb:test-rollup-test_data-pass-fail (lambda (test-id) - (debug:print 4 "INFO: Remote call of cdb:test-rollup-iterated-pass-fail " test-id) - (cdb:test-rollup-iterated-pass-fail test-id))) + (debug:print 4 "INFO: Remote call of cdb:test-rollup-test_data-pass-fail " test-id) + (cdb:test-rollup-test_data-pass-fail test-id))) (rpc:publish-procedure! 'cdb:pass-fail-counts (lambda (test-id fail-count pass-count) (debug:print 4 "INFO: Remote call of cdb:pass-fail-counts " test-id " passes: " pass-count " fails: " fail-count) @@ -156,10 +156,11 @@ (begin (debug:print 0 "INFO: Starting to shutdown the server side") ;; need to delete only *my* server entry (future use) (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' AND val like ?;" host:port) (thread-sleep! 10) + (debug:print 0 "INFO: Max cached queries was " *max-cache-size*) (debug:print 0 "INFO: Server shutdown complete. Exiting") (exit)) (debug:print 0 "INFO: Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*)) )) (loop (+ 1 count))))