Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -17,10 +17,11 @@ ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs get-keys + get-key-vals test-toplevel-num-items get-test-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running @@ -34,11 +35,14 @@ test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status - register-run + get-run-stats + get-targets + get-target + ;; register-run get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs @@ -49,10 +53,11 @@ get-runs-by-patt get-steps-data get-steps-for-test read-test-data login + tasks-get-last testmeta-get-record have-incompletes? synchash-get )) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo typed-records) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -81,10 +81,11 @@ (define *passnum* 0) ;; when running track calls to run-tests or similar (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) +(define *time-zero* (current-seconds)) ;; for the watchdog ;; DATABASE (define *dbstruct-db* #f) (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) @@ -96,10 +97,11 @@ (define *db-write-access* #t) (define *inmemdb* #f) (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) +(define *db-cache-path* #f) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg @@ -113,10 +115,11 @@ (define *received-response* #f) (define *default-numtries* 10) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) +(define *home-host* #f) (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 @@ -196,11 +199,12 @@ ;; 'new2old 'killservers 'dejunk ;; 'adj-testids ;; 'old2new - 'new2old) + 'new2old + 'schema) (if (common:version-changed?) (common:set-last-run-version))) ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; @@ -345,36 +349,99 @@ ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* - '((0 "COMPLETED") - (1 "NOT_STARTED") - (2 "RUNNING") - (3 "REMOTEHOSTSTART") - (4 "LAUNCHED") - (5 "KILLED") - (6 "KILLREQ") - (7 "STUCK") - (8 "ARCHIVED"))) + '((0 "ARCHIVED") + (1 "STUCK") + (2 "KILLREQ") + (3 "KILLED") + (4 "NOT_STARTED") + (5 "RUNNING") + (6 "LAUNCHED") + (7 "REMOTEHOSTSTART") + (8 "COMPLETED") + )) (define *common:std-statuses* - '((0 "PASS") - (1 "WARN") - (2 "FAIL") + '(;; (0 "DELETED") + (1 "n/a") + (2 "PASS") (3 "CHECK") - (4 "n/a") - (5 "WAIVED") - (6 "SKIP") - (7 "DELETED") - (8 "STUCK/DEAD") + (4 "SKIP") + (5 "WARN") + (6 "WAIVED") + (7 "STUCK/DEAD") + (8 "FAIL") (9 "ABORT"))) + +(define (common:special-sort items order comp) + (let ((items-order (map reverse order)) + (acomp (or comp >))) + (sort items + (lambda (a b) + (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) + (b-num (cadr (or (assoc b items-order) '(0 0))))) + (acomp a-num b-num)))))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED)) +;; given a toplevel with currstate, currstatus apply state and status +;; => (newstate . newstatus) +(define (common:apply-state-status currstate currstatus state status) + (let* ((cstate (string->symbol (string-downcase currstate))) + (cstatus (string->symbol (string-downcase currstatus))) + (sstate (string->symbol (string-downcase state))) + (sstatus (string->symbol (string-downcase status))) + (nstate #f) + (nstatus #f)) + (set! nstate + (case cstate + ((completed not_started killed killreq stuck archived) + (case sstate ;; completed -> sstate + ((completed killed killreq stuck archived) completed) + ((running remotehoststart launched) running) + (else unknown-error-1))) + ((running remotehoststart launched) + (case sstate + ((completed killed killreq stuck archived) #f) ;; need to look at all items + ((running remotehoststart launched) running) + (else unknown-error-2))) + (else unknown-error-3))) + (set! nstatus + (case sstatus + ((pass) + (case nstate + ((pass n/a deleted) pass) + ((warn) warn) + ((fail) fail) + ((check) check) + ((waived) waived) + ((skip) skip) + ((stuck/dead) stuck) + ((abort) abort) + (else unknown-error-4))) + ((warn) + (case nstate + ((pass warn n/a skip deleted) warn) + ((fail) fail) + ((check) check) + ((waived) waived) + ((stuck/dead) stuck) + (else unknown-error-5))) + ((fail) + (case nstate + ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail) + ((abort) abort) + (else unknown-error-6))) + (else unknown-error-7))) + (cons + (if nstate (symbol->string nstate) nstate) + (if nstatus (symbol->string nstatus) nstatus)))) + ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== (define *verbosity* 1) @@ -392,26 +459,104 @@ (or (configf:lookup *configdat* "setup" "testsuite" ) (if *toppath* (pathname-file *toppath*) (pathname-file (current-directory))))) +(define (common:get-db-tmp-area) + (if *db-cache-path* + *db-cache-path* + (let ((dbpath (create-directory (conc "/tmp/" (current-user-name) + "/megatest_localdb/" + (common:get-testsuite-name) "/" + (string-translate *toppath* "/" ".")) #t))) + (set! *db-cache-path* dbpath) + dbpath))) + +(define (common:get-area-path-signature) + (message-digest-string (md5-primitive) *toppath*)) + ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) - (or (args:get-arg "-runtests") + (or (and (common:get-homehost) + (cdr (common:get-homehost))) + (args:get-arg "-runtests") (args:get-arg "-run") (args:get-arg "-server") ;; (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") ;; (args:get-arg "-get-run-status") + (args:get-arg "-use-db-cache") ;; feels like a bad idea ... )) (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) +;; run-ids +;; if #f use *db-local-sync* : or 'local-sync-flags +;; if #t use timestamps : or 'timestamps +(define (common:sync-to-megatest.db run-ids) + (let ((start-time (current-seconds)) + (run-ids-to-process (if (list? run-ids) + run-ids + (if (or (eq? run-ids 'timestamps)(eq? run-ids #t)) + (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db")) + (mtdb-exists (file-exists? mtdb-fpath))) + (if mtdb-exists + (file-modification-time mtdb-fpath) + 0))) + (hash-table-keys *db-local-sync*))))) + (debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process) + (for-each + (lambda (run-id) + (mutex-lock! *db-multi-sync-mutex*) + (if (or run-ids ;; if we were provided with run-ids, proceed + (hash-table-ref/default *db-local-sync* run-id #f)) + ;; (if (> (- start-time last-write) 5) ;; every five seconds + (begin ;; let ((sync-time (- (current-seconds) start-time))) + (db:multi-db-sync (list run-id) 'new2old) + (let ((sync-time (- (current-seconds) start-time))) + (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") + (if (common:low-noise-print 30 "sync new to old") + (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + (hash-table-delete! *db-local-sync* run-id))) + (mutex-unlock! *db-multi-sync-mutex*)) + run-ids-to-process))) + +(define (common:watchdog) + (thread-sleep! 0.05) ;; delay for startup + (let ((legacy-sync (common:legacy-sync-required)) + (debug-mode (debug:debug-mode 1)) + (last-time (current-seconds))) + (if (or (common:legacy-sync-recommended) + legacy-sync) + (let loop () + ;; sync for filesystem local db writes + ;; + (let ((start-time (current-seconds))) + (common:sync-to-megatest.db 'local-sync-flags) + (if (and debug-mode + (> (- start-time last-time) 60)) + (begin + (set! last-time start-time) + (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (let delay-loop ((count 0)) + (if (and (not *time-to-exit*) + (< count 4)) ;; was 11, changing to 4. + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (loop))) + (if (common:low-noise-print 30) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))) + (define (std-exit-procedure) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) @@ -418,15 +563,17 @@ #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (let ((run-ids (hash-table-keys *db-local-sync*))) - (if (and (not (null? run-ids)) - (or (common:legacy-sync-recommended) - (configf:lookup *configdat* "setup" "megatest-db"))) - (if no-hurry (db:multi-db-sync run-ids 'new2old)))) + ;; (let ((run-ids (hash-table-keys *db-local-sync*))) + ;; (if (and (not (null? run-ids)) + ;; (or (common:legacy-sync-recommended) + ;; (configf:lookup *configdat* "setup" "megatest-db"))) + ;; (if no-hurry + ;; (db:multi-db-sync run-ids 'new2old)) + ;; )) (if *dbstruct-db* (db:close-all *dbstruct-db*)) (if *inmemdb* (db:close-all *inmemdb*)) (if (and *megatest-db* (sqlite3:database? *megatest-db*)) (begin @@ -549,10 +696,31 @@ (pathname-directory (pathname-directory (pathname-directory exe-path)))) #f))) +;; return first path that can be created or already exists and is writable +;; +(define (common:get-create-writeable-dir dirs) + (if (null? dirs) + #f + (let loop ((hed (car dirs)) + (tal (cdr dirs))) + (let ((res (or (and (directory? hed) + (file-write-access? hed) + hed) + (handle-exceptions + exn + #f + (create-directory hed #t))))) + (if (and (string? res) + (directory? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== @@ -613,10 +781,36 @@ (if target (begin (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") #f) #f)))) + +;; logic for getting homehost. Returns (host . at-home) +;; +(define (common:get-homehost) + (cond + (*home-host* *home-host*) + ((not *toppath*) #f) ;; don't know toppath yet? return #f + (else + (let* ((currhost (get-host-name)) + (bestadrs (server:get-best-guess-address currhost)) + ;; first look in config, then look in file .homehost, create it if not found + (homehost (or (configf:lookup *configdat* "server" "homehost" ) + (let ((hhf (conc *toppath* "/.homehost"))) + (if (file-exists? hhf) + (with-input-from-file hhf read-line) + (if (file-write-access? *toppath*) + (begin + (with-output-to-file hhf + (lambda () + (print bestadrs))) + (common:get-homehost)) + #f))))) + (at-home (or (equal? homehost currhost) + (equal? homehost bestadrs)))) + (set! *home-host* (cons homehost at-home)) + *home-host*)))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== @@ -923,30 +1117,36 @@ (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) -;; check space in dbdir -;; returns: ok/not dbspace required-space -;; -(define (common:check-db-dir-space) - (let* ((dbdir (db:get-dbdir)) - (dbspace (if (directory? dbdir) - (get-df dbdir) - 0)) - (required (string->number - (or (configf:lookup *configdat* "setup" "dbdir-space-required") - "100000")))) +(define (common:check-space-in-dir dirpath required) + (let* ((dbspace (if (directory? dirpath) + (get-df dirpath) + 0))) (list (> dbspace required) dbspace required - dbdir))) + dirpath))) +;; check space in dbdir and in megatest dir +;; returns: ok/not dbspace required-space +;; +(define (common:check-db-dir-space) + (let* ((required (string->number + (or (configf:lookup *configdat* "setup" "dbdir-space-required") + "100000"))) + (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir)) + (tdbspace (common:check-space-in-dir dbdir required)) + (mdbspace (common:check-space-in-dir *toppath* required))) + (sort (list tdbspace mdbspace) (lambda (a b) + (< (cadr a)(cadr b)))))) + ;; check available space in dbdir, exit if insufficient ;; (define (common:check-db-dir-and-exit-if-insufficient) - (let* ((spacedat (common:check-db-dir-space)) + (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now (is-ok (car spacedat)) (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -17,12 +17,12 @@ (require-library iup) (import (prefix iup iup:)) (use canvas-draw) -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) +(use srfi-1 posix regex regex-case srfi-69) +(use (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) @@ -158,11 +158,11 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== (define (run-info-panel db keydat testdat runname) (let* ((run-id (db:test-get-run_id testdat)) - (rundat (db:get-run-info db run-id)) + (rundat (rmt:get-run-info run-id)) (header (db:get-header rundat)) (event_time (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "event_time"))) (iup:frame @@ -286,11 +286,12 @@ (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 run-id test-id state #f #f) + ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) + (rmt:roll-up-pass-fail-counts run-id test-id #f state #f) ;; test-name passed in as test-id is respected (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) @@ -319,11 +320,12 @@ (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) )))) (begin - (rmt:test-set-state-status-by-id run-id test-id #f status #f) + ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (rmt:roll-up-pass-fail-counts run-id test-id #f #f status) ;; test-name passed in as test-id is respected (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) @@ -415,13 +417,13 @@ ;;====================================================================== ;; ;;====================================================================== (define (dashboard-tests: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") - local: #t)) + (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct 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)) (if (not testdat) @@ -513,11 +515,11 @@ ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) (rmt:get-test-info-by-id run-id test-id ))))) - ;; (debug:print-info 0 *default-log-port* "need-update= " need-update " curr-mod-time = " curr-mod-time) + ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (tests:get-compressed-steps run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -53,10 +53,11 @@ Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check + -use-db-cache : access database via cache Misc -rows R : set number of rows -cols C : set number of columns ")) @@ -81,12 +82,13 @@ "-use-server" "-guimonitor" "-main" "-v" "-q" - "-use-local" + "-use-db-cache" "-skip-version-check" + "-repl" ) args:arg-hash 0)) (if (not (null? remargs)) @@ -104,10 +106,19 @@ (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) +;; create a watch dog to move changes from lt/.db/*.db to megatest.db +;; +(if (file-write-access? (conc *toppath* "/megatest.db")) + (thread-start! (make-thread common:watchdog "Watchdog thread")) + (if (not (args:get-arg "-use-db-cache")) + (begin + (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") + (hash-table-set! args:arg-hash "-use-db-cache" #t)))) + ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) please-update @@ -116,11 +127,10 @@ updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs ) - (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 tabdats: (make-hash-table) @@ -248,10 +258,11 @@ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f (target #f) (test-patts #f) ;; db info to file the .db files for the area + (access-mode (db:get-access-mode)) ;; use cached db or not (dbdir #f) (dbfpath #f) (dbkeys #f) ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp (monitor-db-path #f) ;; where to find monitor.db @@ -261,11 +272,11 @@ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) ;; runs tree ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id (runs-tree #f) - ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targests added to tree (merge functionality with path-run-ids?) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) ;; tab data ((view-changed #t) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) @@ -297,18 +308,18 @@ (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) - (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0)) + (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) + (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) ;; RADT => Matrix defstruct addition @@ -479,21 +490,22 @@ ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((num-to-get + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (num-to-get (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get"))) (if num-tests-from-config (begin (BB> "override num-tests 100 -> "num-tests-from-config) (string->number num-tests-from-config)) 100))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) - (do-not-use-db-file-timestamps (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab - (do-not-use-query-timestamps (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab + (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname @@ -516,29 +528,30 @@ (db-pth (conc db-dir "/" run-id ".db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (tmptests (if (or do-not-use-db-file-timestamps (>= (common:lazy-modification-time db-path) last-update)) - (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses - (dboard:rundat-run-data-offset run-dat) - num-to-get - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) ;; last-update - *dashboard-mode*) ;; use dashboard mode + (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run + run-id testnamepatt states statuses ;; run-id testpatt states statuses + (dboard:rundat-run-data-offset run-dat) + num-to-get + (dboard:tabdat-hide-not-hide tabdat) ;; no-in + sort-by ;; sort-by + sort-order ;; sort-order + #f ;; 'shortlist ;; qrytype + (if (dboard:tabdat-filters-changed tabdat) + 0 + last-update) ;; last-update + *dashboard-mode*) ;; use dashboard mode '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) (let ((ht (make-hash-table))) (dboard:rundat-tests-set! run-dat ht) ht) - (dboard:rundat-tests run-dat))) - (start-time (current-seconds))) + (dboard:rundat-tests run-dat)))) + ;;(start-time (current-seconds))) ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset (dboard:rundat-run-data-offset-set! run-dat (if (< (length tmptests) num-to-get) @@ -592,15 +605,18 @@ ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((keys (rmt:get-keys)) - (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (db:dispatch-query access-mode rmt:get-keys db:get-keys)) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) + (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs + runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update));;'("id" "runname") + (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + keys "%" #f #f #f #f last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -662,12 +678,88 @@ (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:update-tree tabdat runs-hash header tb))) - - +;; this calls dboard:get-tests-for-run-duplicate for each run +;; +;; create a virtual table of all the tests +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +;; +(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) + (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs + runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs-tree) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (dboard:tabdat-header-set! tabdat header) + ;; + ;; trim runs to only those that are changing often here + ;; + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) + (let loop ((run (car runs)) + (tal (cdr runs)) + (res '()) + (maxtests 0)) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) + ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) + (key-vals (rmt:get-key-vals run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) + (all-test-ids (hash-table-keys tests-ht)) + (num-tests (length all-test-ids))) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (let* ((newmaxtests (max num-tests maxtests)) + ;; (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) res (cons run-struct res))) + (elapsed-time (- (current-seconds) start-time))) + (if (null? all-test-ids) + (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) + (if (or (null? tal) + (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update + (begin + (if (> elapsed-time 2)(print "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (if (> (dboard:rundat-run-data-offset run-struct) 0) + (loop run tal new-res newmaxtests) ;; not done getting data for this run + (loop (car tal)(cdr tal) new-res newmaxtests))))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:update-tree tabdat runs-hash header tb))) (define *collapsed* (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) @@ -1476,11 +1568,13 @@ (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) (define (dboard:get-tests-dat tabdat run-id last-update) - (let* ((tdat (if run-id (rmt:get-tests-for-run run-id + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run + run-id (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() #f #f ;; offset limit (dboard:tabdat-hide-not-hide tabdat) ;; not-in @@ -1507,20 +1601,22 @@ (if (and res (> (length res) 1)) (cadr res) #f))) (define (dboard:update-tree tabdat runs-hash runs-header tb) - (let* ((run-ids (sort (filter number? (hash-table-keys runs-hash)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) @@ -1585,12 +1681,14 @@ hide-clean: hide-clean) #f))) (define (dashboard:get-runs-hash tabdat) - (let* ((last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) + (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1598,15 +1696,17 @@ runs) ht))) runs-hash)) (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) - (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) - (dashboard:do-update-rundat tabdat)) + ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) + (dashboard:do-update-rundat tabdat) ;; ) (dboard:runs-summary-control-panel-updater tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (db:dispatch-query (dboard:tabdat-access-mode tabdat) + rmt:get-runs-by-patt db:get-runs-by-patt + (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (dashboard:get-runs-hash tabdat)) ;; (runs-hash (let ((ht (make-hash-table))) @@ -2034,11 +2134,10 @@ (mark-for-update tabdat) (update-search commondat tabdat "test-name" val)) "make-controls"))) (iup:hbox (iup:button "Quit" #:action (lambda (obj) - ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat))) (exit)) #:expand "NO" #:size "40x15") (iup:button "Refresh" #:action (lambda (obj) (mark-for-update tabdat)) #:expand "NO" #:size "40x15") @@ -2567,29 +2666,29 @@ (define *last-recalc-ended-time* 0) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons - (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) - (> modtime last-db-update-time) + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin (> (current-seconds)(+ last-db-update-time 1))))) ;; (define *monitor-db-path* #f) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. (tasks:open-db) -(define (dashboard:get-youngest-run-db-mod-time tabdat) +(define (dashboard:get-youngest-run-db-mod-time dbdir) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (common:max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc (dboard:tabdat-dbdir tabdat) "/*.db")))))) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path)) @@ -2607,19 +2706,23 @@ (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) (define (dboard:set-last-db-update! tabdat context newtime) (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; (define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) (let* ((run-update-time (current-seconds)) - (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! + (dbdir (dboard:tabdat-dbdir tabdat)) + (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) - (dboard:get-last-db-update tabdat context-key)))) - ;; (dboard:tabdat-last-db-update tabdat)))) + (dboard:get-last-db-update tabdat context-key)))) + ;; (dboard:tabdat-last-db-update tabdat)))) (if recalc - (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:set-last-db-update! tabdat context-key run-update-time)) (dboard:commondat-please-update-set! commondat #f) recalc)) ;; point inside line ;; @@ -2713,12 +2816,15 @@ (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (db:dispatch-query access-mode + rmt:get-runs-by-patt db:get-runs-by-patt + (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) @@ -3256,15 +3362,16 @@ ;; (define (tabdat-values tabdat) ;; runs update-rundat using the various filters from the gui ;; (define (dashboard:do-update-rundat tabdat) - (update-rundat + (dboard:update-rundat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; generate key patterns from the target stored in tabdat (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) (let ((fres (if (dboard:tabdat-target tabdat) (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) (map (lambda (k v)(list k v)) dbkeys ptparts)) (let ((res '())) @@ -3282,13 +3389,14 @@ (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) + ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) (dashboard:do-update-rundat tabdat) (let ((uidat (dboard:commondat-uidat commondat))) - ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) + ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) ;;====================================================================== @@ -3319,11 +3427,11 @@ (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ;; ((args:get-arg "-guimonitor") ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) (else - (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data) + (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) @@ -3357,7 +3465,9 @@ ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(main) +(if (args:get-arg "-repl") + (repl) + (main)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -38,24 +38,15 @@ ;;====================================================================== ;; R E C O R D S ;;====================================================================== +;; each db entry is a pair ( db . dbfilepath ) (defstruct dbr:dbstruct - main - strdb - ((path #f) : string) - ((local #f) : boolean) - rundb - inmem - mtime - rtime - stime - inuse - refdb - ((locdbs (make-hash-table)) : hash-table) - olddb) + (tmpdb #f) + (mtdb #f) + (refndb #f)) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== @@ -86,22 +77,15 @@ ;; if #f => get main db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; -(define (db:get-db dbstruct run-id) - (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through - dbstruct - (begin - (let ((dbdat (if (or (not run-id) - (eq? run-id 0)) - (db:open-main dbstruct) - (db:open-rundb dbstruct run-id) - ))) - dbdat)))) - -;; legacy handling of structure for managing db's. Refactor this into dbr:? +(define (db:get-db dbstruct . blah) ;; run-id) + (or (dbr:dbstruct-tmpdb dbstruct) + (db:open-db dbstruct))) + +;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) @@ -113,35 +97,38 @@ ;; mod-read: ;; 'mod modified data ;; 'read read data ;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct ;; -(define (db:done-with dbstruct run-id mod-read) - (if (not (sqlite3:database? dbstruct)) - (begin - (mutex-lock! *rundb-mutex*) - (if (eq? mod-read 'mod) - (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds)) - (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds))) - (dbr:dbstruct-inuse-set! dbstruct #f) - (mutex-unlock! *rundb-mutex*)))) - -;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") +;; (define (db:done-with dbstruct run-id mod-read) +;; (if (not (sqlite3:database? dbstruct)) +;; (begin +;; (mutex-lock! *rundb-mutex*) +;; (if (eq? mod-read 'mod) +;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds)) +;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds))) +;; (dbr:dbstruct-inuse-set! dbstruct #f) +;; (mutex-unlock! *rundb-mutex*)))) + +;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) (let* ((dbdat (if (dbr:dbstruct? dbstruct) (db:get-db dbstruct run-id) - dbstruct)) ;; cheat, allow for passing in a dbdat + (begin + (print-call-chain) + (print "db:with-db called with dbdat instead of dbstruct, FIXME!!") + dbstruct))) ;; cheat, allow for passing in a dbdat (db (db:dbdat-get-db dbdat))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) (let ((res (apply proc db params))) - (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) res)))) ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== @@ -169,30 +156,30 @@ ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; ;; If run-id is #f return to create and retrieve the path where the db will live. ;; -(define (db:dbfile-path run-id) - (let* ((dbdir (db:get-dbdir)) - (fname (if run-id - (if (eq? run-id 0) "main.db" (conc run-id ".db")) - #f))) +(define (db:dbfile-path . junk) ;; run-id) + (let* ((dbdir (common:get-db-tmp-area))) ;; (db:get-dbdir)) +;; (fname (if run-id +;; (if (eq? run-id 0) "main.db" (conc run-id ".db")) +;; #f))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) - (if fname - (conc dbdir "/" fname) - dbdir))) + dbdir)) ;; (if fname +;; (conc dbdir "/" fname) +;; dbdir))) ;; Returns the database location as specified in config file ;; -(define (db:get-dbdir) - (or (configf:lookup *configdat* "setup" "dbdir") - (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) +;; (define db:get-dbdir common:get-db-tmp-area) +;; (or (configf:lookup *configdat* "setup" "dbdir") +;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) @@ -199,16 +186,11 @@ ;; open an sql database inside a file lock ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; (define (db:lock-create-open fname initproc) - ;; (if (file-exists? fname) - ;; (let ((db (sqlite3:open-database fname))) - ;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - ;; (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - ;; db) - (let* ((parent-dir (pathname-directory fname)) + (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) @@ -227,122 +209,95 @@ db) (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) (sqlite3:open-database fname))))) ;; ) -;; 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 dbstruct run-id) - (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-runrec dbstruct run-id 'inmem))) - (if (or rdb - do-not-open) - rdb - (begin - (mutex-lock! *rundb-mutex*) - (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) - (dbexists (file-exists? dbpath)) - (inmem (if local #f (db:open-inmem-db))) - (refdb (if local #f (db:open-inmem-db))) - (db (db:lock-create-open dbpath ;; this is the database physically on disk - (lambda (db) - (handle-exceptions - exn - (begin - ;; (release-dot-lock dbpath) - (if (> attemptnum 2) - (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) - (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) - (db:initialize-run-id-db db) - (sqlite3:execute - db - "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" - (* run-id 30000) ;; allow for up to 30k tests per run - run-id) - ;; do a dummy query to test that the table exists and the db is truly readable - (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) - )))) ;; add strings db to rundb, not in use yet - ;; )) ;; (sqlite3:open-database dbpath)) - (olddb (if *megatest-db* - *megatest-db* - (let ((db (db:open-megatest-db))) - (set! *megatest-db* db) - db))) - (write-access (file-write-access? dbpath)) - ;; (handler (make-busy-timeout 136000)) - ) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) ;; only unset so other db's also can use this control - (dbr:dbstruct-rundb-set! dbstruct (cons db dbpath)) - (dbr:dbstruct-inuse-set! dbstruct #t) - (dbr:dbstruct-olddb-set! dbstruct olddb) - ;; (dbr:dbstruct-run-id-set! dbstruct run-id) - (mutex-unlock! *rundb-mutex*) - (if local - (begin - (dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-inmem-set! dbstruct db) ;; direct access ... - db) - (begin - (dbr:dbstruct-inmem-set! dbstruct inmem) - ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders - ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context - (db:sync-tables db:sync-tests-only db inmem) - (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? - (dbr:dbstruct-refdb-set! dbstruct refdb) - (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db - ;; sync once more to deal with delays? - ;; (db:sync-tables db:sync-tests-only db inmem) - ;; (db:sync-tables db:sync-tests-only inmem refdb) - inmem))))))) - -;; This routine creates the db if not already present. It is only called if the db is not already ls opened -;; -(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let ((mdb (dbr:dbstruct-main dbstruct))) ;; RA => Returns the first reference in dbstruct - (if mdb - mdb - (begin - (mutex-lock! *rundb-mutex*) - (let* ((dbpath (db:dbfile-path 0)) - (dbexists (file-exists? dbpath)) - (db (db:lock-create-open dbpath db:initialize-main-db)) - (olddb (db:open-megatest-db)) - (write-access (file-write-access? dbpath)) - (dbdat (cons db dbpath))) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) - (dbr:dbstruct-main-set! dbstruct dbdat) - (dbr:dbstruct-olddb-set! dbstruct olddb) ;; olddb is already a (cons db path) - (mutex-unlock! *rundb-mutex*) - (if (and (not dbexists) - *db-write-access*) ;; did not have a prior db and do have write access - (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically - dbdat))))) +;; ;; 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* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) +;; (dbexists (file-exists? dbfile)) +;; (db (db:lock-create-open dbfile (lambda (db) +;; (handle-exceptions +;; exn +;; (begin +;; ;; (release-dot-lock dbpath) +;; (if (> attemptnum 2) +;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) +;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) +;; (db:initialize-run-id-db db) +;; (sqlite3:execute +;; db +;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" +;; (* run-id 30000) ;; allow for up to 30k tests per run +;; run-id) +;; ;; do a dummy query to test that the table exists and the db is truly readable +;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) +;; )))) ;; add strings db to rundb, not in use yet +;; (olddb (if *megatest-db* +;; *megatest-db* +;; (let ((db (db:open-megatest-db))) +;; (set! *megatest-db* db) +;; db))) +;; (write-access (file-write-access? dbfile))) +;; (if (and dbexists (not write-access)) +;; (set! *db-write-access* #f)) ;; only unset so other db's also can use this control +;; (dbr:dbstruct-rundb-set! dbstruct (cons db dbfile)) +;; (dbr:dbstruct-inuse-set! dbstruct #t) +;; (dbr:dbstruct-olddb-set! dbstruct olddb) +;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? +;; (db:sync-tables db:sync-tests-only *megatest-db* db) +;; db)) + +;; This routine creates the db if not already present. It is only called if the db is not already opened +;; +(define (db:open-db dbstruct #!key (areapath #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct + (if tmpdb + tmpdb + ;; (mutex-lock! *rundb-mutex*) + (let* ((dbpath (db:dbfile-path)) ;; 0)) + (dbexists (file-exists? dbpath)) + (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) + (mtdb (db:open-megatest-db)) + (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) + (write-access (file-write-access? dbpath))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (dbr:dbstruct-mtdb-set! dbstruct mtdb) + (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) ;; olddb is already a (cons db path) + (dbr:dbstruct-refndb-set! dbstruct refndb) + ;; (mutex-unlock! *rundb-mutex*) + (if (and (not dbexists) + *db-write-access*) ;; did not have a prior db and do have write access + (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically + tmpdb)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; -(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))) +(define (db:setup #!key (areapath #f)) ;; . junk) ;; #!key (run-id #f) (local #f)) + (let* (;; (dbdir (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dbstruct (make-dbr:dbstruct))) ;; ) ;; path: dbdir local: local))) + (db:open-db dbstruct areapath: #f) dbstruct)) ;; open the local db for direct access (no server) ;; (define (db:open-local-db-handle) (or *dbstruct-db* - (let ((dbstruct (db:setup #f local: #t))) + (let ((dbstruct (db:setup))) ;; #f local: #t))) (set! *dbstruct-db* dbstruct) dbstruct))) -;; Open the classic megatest.db file in toppath +;; Open the classic megatest.db file (defaults to open in toppath) ;; -(define (db:open-megatest-db) - (let* ((dbpath (conc *toppath* "/megatest.db")) +;; NOTE: returns a dbdat not a dbstruct! +;; +(define (db:open-megatest-db #!key (path #f)(name #f)) + (let* ((dbpath (conc (or path *toppath*) "/" (or name "megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) @@ -352,94 +307,100 @@ (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((mtime (dbr:dbstruct-mtime dbstruct)) - (stime (dbr:dbstruct-stime dbstruct)) - (rundb (dbr:dbstruct-rundb dbstruct)) - (inmem (dbr:dbstruct-inmem dbstruct)) - (maindb (dbr:dbstruct-main dbstruct)) - (refdb (dbr:dbstruct-refdb dbstruct)) - (olddb (dbr:dbstruct-olddb dbstruct)) + (let (;; (mtime (dbr:dbstruct-mtime dbstruct)) + ;; (stime (dbr:dbstruct-stime dbstruct)) + ;; (rundb (dbr:dbstruct-rundb dbstruct)) + ;; (inmem (dbr:dbstruct-inmem dbstruct)) + ;; (maindb (dbr:dbstruct-main dbstruct)) + ;; (refdb (dbr:dbstruct-refdb dbstruct)) + (tmpdb (dbr:dbstruct-tmpdb dbstruct)) + (mtdb (dbr:dbstruct-mtdb dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) ;; (runid (dbr:dbstruct-run-id dbstruct)) ) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) - (if (eq? run-id 0) - ;; runid equal to 0 is main.db - (if maindb - (if (or (not (number? mtime)) - (not (number? stime)) - (> mtime stime) - force-sync) - (begin - (db:delay-if-busy maindb) - (db:delay-if-busy olddb) - (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) - (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) - num-synced) - 0)) - (begin - ;; this can occur when using local access (i.e. not in a server) - ;; need a flag to turn it off. - ;; - (debug:print 3 *default-log-port* "WARNING: call to sync main.db to megatest.db but main not initialized") - 0)) - ;; any other runid is a run - (if (or (not (number? mtime)) - (not (number? stime)) - (> mtime stime) - force-sync) - (begin - (db:delay-if-busy rundb) - (db:delay-if-busy olddb) - (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) - (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) - ;; (mutex-unlock! *http-mutex*) - num-synced) - (begin - ;; (mutex-unlock! *http-mutex*) - 0)))))) - -(define (db:close-main dbstruct) - (let ((maindb (dbr:dbstruct-main dbstruct))) - (if maindb - (begin - (sqlite3:finalize! (db:dbdat-get-db maindb)) - (dbr:dbstruct-main-set! dbstruct #f))))) - -(define (db:close-run-db dbstruct run-id) - (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) - (if (and rdb - (sqlite3:database? rdb)) - (begin - (sqlite3:finalize! rdb) - (dbr:dbstruct-localdb-set! dbstruct run-id #f) - (dbr:dbstruct-inmem-set! dbstruct #f))))) + (db:sync-tables (db:sync-all-tables-list tmpdb) #f tmpdb refndb mtdb))) +;; (if (eq? run-id 0) +;; ;; runid equal to 0 is main.db +;; (if maindb +;; (if (or (not (number? mtime)) +;; (not (number? stime)) +;; (> mtime stime) +;; force-sync) +;; (begin +;; (db:delay-if-busy maindb) +;; (db:delay-if-busy olddb) +;; (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) +;; (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) +;; num-synced) +;; 0)) +;; (begin +;; ;; this can occur when using local access (i.e. not in a server) +;; ;; need a flag to turn it off. +;; ;; +;; (debug:print 3 *default-log-port* "WARNING: call to sync main.db to megatest.db but main not initialized") +;; 0)) +;; ;; any other runid is a run +;; (if (or (not (number? mtime)) +;; (not (number? stime)) +;; (> mtime stime) +;; force-sync) +;; (begin +;; (db:delay-if-busy rundb) +;; (db:delay-if-busy olddb) +;; (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) +;; (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) +;; ;; (mutex-unlock! *http-mutex*) +;; num-synced) +;; (begin +;; ;; (mutex-unlock! *http-mutex*) +;; 0)))))) + +;; (define (db:close-main dbstruct) +;; (let ((maindb (dbr:dbstruct-main dbstruct))) +;; (if maindb +;; (begin +;; (sqlite3:finalize! (db:dbdat-get-db maindb)) +;; (dbr:dbstruct-main-set! dbstruct #f))))) +;; +;; (define (db:close-run-db dbstruct run-id) +;; (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) +;; (if (and rdb +;; (sqlite3:database? rdb)) +;; (begin +;; (sqlite3:finalize! rdb) +;; (dbr:dbstruct-localdb-set! dbstruct run-id #f) +;; (dbr:dbstruct-inmem-set! dbstruct #f))))) ;; close all opened run-id dbs (define (db:close-all dbstruct) - ;; finalize main.db - (db:sync-touched dbstruct 0 force-sync: #t) - ;;(common:db-block-further-queries) - ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? - - (db:close-main dbstruct) - - (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) - (if (hash-table? locdbs) - (for-each (lambda (run-id) - (db:close-run-db dbstruct run-id)) - (hash-table-keys locdbs))))) - -(define (db:open-inmem-db) - (let* ((db (sqlite3:open-database ":memory:")) - (handler (make-busy-timeout 3600))) - (sqlite3:set-busy-handler! db handler) - (db:initialize-run-id-db db) - (cons db #f))) + (if (dbr:dbstruct? dbstruct) + (begin + (db:sync-touched dbstruct 0 force-sync: #t) + (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) + (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) + (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) + (if tdb (sqlite3:finalize! tdb)) + (if mdb (sqlite3:finalize! mdb)) + (if rdb (sqlite3:finalize! rdb)))))) + +;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) +;; (if (hash-table? locdbs) +;; (for-each (lambda (run-id) +;; (db:close-run-db dbstruct run-id)) +;; (hash-table-keys locdbs))))) + +;; (define (db:open-inmem-db) +;; (let* ((db (sqlite3:open-database ":memory:")) +;; (handler (make-busy-timeout 3600))) +;; (sqlite3:set-busy-handler! db handler) +;; (db:initialize-run-id-db db) +;; (cons db #f))) ;; just tests, test_steps and test_data tables (define db:sync-tests-only (list ;; (list "strs" @@ -489,12 +450,12 @@ '("status" #f) '("type" #f)))) ;; needs db to get keys, this is for syncing all tables ;; -(define (db:sync-main-list db) - (let ((keys (db:get-keys db))) +(define (db:sync-main-list dbstruct) + (let ((keys (db:get-keys dbstruct))) (list (list "keys" '("id" #f) '("fieldname" #f) '("fieldtype" #f)) @@ -513,10 +474,14 @@ '("iterated" #f) '("avg_runtime" #f) '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) + +(define (db:sync-all-tables-list dbstruct) + (append (db:sync-main-list dbstruct) + db:sync-tests-only)) ;; use bunch of Unix commands to try to break the lock and recreate the db ;; (define (db:move-and-recreate-db dbdat) (let* ((dbpath (db:dbdat-get-path dbdat)) @@ -591,11 +556,15 @@ #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; -(define (db:sync-tables tbls fromdb todb . slave-dbs) +;; if last-update specified ("field-name" . time-in-seconds) +;; then sync only records where field-name >= time-in-seconds +;; IFF field-name exists +;; +(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (mutex-unlock! *db-sync-mutex*) @@ -639,15 +608,26 @@ (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) + (use-last-update (if last-update + (if (pair? last-update) + (member (car last-update) ;; last-update field name + (map car fields)) + (begin + (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair, received: " last-update) ;; found in fields + #f)) + #f)) (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 ";")) + " FROM " tablename (if use-last-update ;; apply last-update criteria + (conc " " (car last-update) ">=" (cdr last-update)) + "") + ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) @@ -720,11 +700,12 @@ fromdats) (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (should-print (or (debug:debug-mode 12) + (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) @@ -734,11 +715,11 @@ (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))) (mutex-unlock! *db-sync-mutex*))) -(define (db:patch-schema-rundb run-id frundb) +(define (db:patch-schema-rundb frundb) ;; ;; remove this some time after September 2016 (added in version v1.6031 ;; (for-each (lambda (table-name) @@ -762,19 +743,19 @@ WHERE id=old.id; END;")) ) '("tests" "test_steps" "test_data"))) -(define (db:patch-schema-maindb run-id maindb) +(define (db:patch-schema-maindb maindb) ;; ;; remove all these some time after september 2016 (added in v1.6031 ;; (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none")) + (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) (sqlite3:execute maindb "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) ;; these schema changes don't need exception handling (sqlite3:execute @@ -796,141 +777,224 @@ FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;")) + +(define *global-db-store* (make-hash-table)) + +(define (db:get-access-mode) + (if (args:get-arg "-use-db-cache") 'cached 'rmt)) + +;; Add db direct +;; +(define (db:dispatch-query access-mode rmt-cmd db-cmd . params) + (if (eq? access-mode 'cached) + (print "not doing cached calls right now")) +;; (apply db:call-with-cached-db db-cmd params) + (apply rmt-cmd params)) +;;) + +;; return the target db handle so it can be used +;; +(define (db:cache-for-read-only source target #!key (use-last-update #f)) + (if (and (hash-table-ref/default *global-db-store* target #f) + (>= (file-modification-time target)(file-modification-time source))) + (hash-table-ref *global-db-store* target) + (let* ((toppath (launch:setup)) + (targ-db-last-mod (if (file-exists? target) + (file-modification-time target) + 0)) + (cache-db (or (hash-table-ref/default *global-db-store* target #f) + (db:open-megatest-db path: target))) + (source-db (db:open-megatest-db path: source)) + (curr-time (current-seconds)) + (res '()) + (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f))) + (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) + (db:sync-tables db:sync-tests-only last-update source-db cache-db) + (hash-table-set! *global-db-store* target cache-db) + cache-db))) + +;; call a proc with a cached db +;; +(define (db:call-with-cached-db proc . params) + ;; first cache the db in /tmp + (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) + (fname (conc (common:get-area-path-signature) ".db")) + (cache-dir (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) "/" cname-part) + (conc "/tmp/" (current-user-name) "-" cname-part) + (conc "/tmp/" (current-user-name) "_" cname-part)))) + (megatest-db (conc *toppath* "/megatest.db"))) + ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) + (if (not cache-dir) + (begin + (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") + (exit 1)) + (let* ((th1 (make-thread + (lambda () + (if (and (file-exists? megatest-db) + (file-write-access? megatest-db)) + (begin + (common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync* + (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) + "call-with-cached-db sync-to-megatest.db")) + (cache-db (db:cache-for-read-only + megatest-db + (conc cache-dir "/" fname) + use-last-update: #t))) + (thread-start! th1) + (apply proc cache-db params) + )))) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges ;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db ;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db ;; 'closeall - close all opened dbs +;; 'schema - attempt to apply schema changes ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) - (let* ((toppath (launch:setup)) - (dbstruct (if toppath (make-dbr:dbstruct 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 - (db:delay-if-busy mtdb) - (db:get-all-run-ids mtdb))))) - (tdbdat (tasks:open-db)) - (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) - - ;; kill servers - (if (member 'killservers options) - (for-each - (lambda (server) - (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") - (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) - servers)) - - ;; clear out junk records - ;; - (if (member 'dejunk options) - (begin - (db:delay-if-busy mtdb) - (db:clean-up mtdb))) - - ;; adjust test-ids to fit into proper range - ;; - (if (member 'adj-testids options) - (begin - (db:delay-if-busy mtdb) - (db:prep-megatest.db-for-migration mtdb))) - - ;; sync runs, test_meta etc. - ;; - (if (member 'old2new options) - (begin - (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))) - (debug:print 0 *default-log-port* "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-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)) - (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 '())) - ;; first fix schema if needed - (map - (lambda (th) - (thread-join! th)) - (map - (lambda (run-id) - (thread-start! - (make-thread - (lambda () - (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) - (if (eq? run-id 0) - (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) - (db:patch-schema-maindb run-id maindb)) - (db:patch-schema-rundb run-id frundb))) - (set! count (+ count 1)) - (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total))))) - all-run-ids)) - ;; Then sync and fix db's - (set! count 0) - (process-fork - (lambda () - (map - (lambda (th) - (thread-join! th)) - (map - (lambda (run-id) - (thread-start! - (make-thread - (lambda () - (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) - (if (eq? run-id 0) - (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) - (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) - (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) - (begin - ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db - (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) - (db:clean-up-rundb (db:get-db fromdb run-id))))) - (set! count (+ count 1)) - (debug:print 0 *default-log-port* "Finished clean up of " - (if (eq? run-id 0) - " main.db " (conc run-id ".db")) ", " count " of " total))))) - all-run-ids)))) - - ;; removed deleted runs - (let ((dbdir (tasks:get-task-db-path))) - (for-each (lambda (run-id) - (let ((fullname (conc dbdir "/" run-id ".db"))) - (if (file-exists? fullname) - (begin - (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) - (delete-file fullname))))) - dead-runs)))) - - ;; (db:close-all dbstruct) - ;; (sqlite3:finalize! mdb) - )) + (if (not (launch:setup)) + (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") + (let* ((dbstruct (db:setup)) + (mtdb (dbr:dbstruct-mtdb dbstruct)) + (tmpdb (dbr:dbstruct-tmpdb dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) + (allow-cleanup (if run-ids #f #t)) +;; (run-ids (if run-ids +;; run-ids +;; (db:get-all-run-ids mtdb))) + (tdbdat (tasks:open-db)) + (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + + ;; kill servers + (if (member 'killservers options) + (for-each + (lambda (server) + (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") + (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) + servers)) + + ;; clear out junk records + ;; + (if (member 'dejunk options) + (begin + (db:delay-if-busy mtdb) ;; ok to delay on mtdb + (db:clean-up mtdb) + (db:clean-up tmpdb) + (db:clean-up refndb))) + + ;; adjust test-ids to fit into proper range + ;; + ;; (if (member 'adj-testids options) + ;; (begin + ;; (db:delay-if-busy mtdb) + ;; (db:prep-megatest.db-for-migration mtdb))) + + ;; sync runs, test_meta etc. + ;; + (if (member 'old2new options) + ;; (begin + (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)) + ;; (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))) +;; (debug:print 0 *default-log-port* "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-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) + (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)) + + (if (member 'fixschema options) + (begin + (db:patch-schema-maindb (db:dbdat-get-db mtdb)) + (db:patch-schema-maindb (db:dbdat-get-db tmpdb)) + (db:patch-schema-maindb (db:dbdat-get-db refndb)) + (db:patch-schema-rundb (db:dbdat-get-db mtdb)) + (db:patch-schema-rundb (db:dbdat-get-db tmpdb)) + (db:patch-schema-rundb (db:dbdat-get-db refndb)))) + + ;; (let* ((maindb (make-dbr:dbstruct 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 '())) + ;; ;; first fix schema if needed + ;; (map + ;; (lambda (th) + ;; (thread-join! th)) + ;; (map + ;; (lambda (run-id) + ;; (thread-start! + ;; (make-thread + ;; (lambda () + ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) +;; (if (member 'schema options) + ;; (if (eq? run-id 0) + ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) + ;; (db:patch-schema-maindb run-id maindb)) + ;; (db:patch-schema-rundb run-id frundb))) + ;; (set! count (+ count 1)) + ;; (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total))))) + ;; all-run-ids)) + ;; ;; Then sync and fix db's + ;; (set! count 0) + ;; (process-fork + ;; (lambda () + ;; (map + ;; (lambda (th) + ;; (thread-join! th)) + ;; (map + ;; (lambda (run-id) + ;; (thread-start! + ;; (make-thread + ;; (lambda () + ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) + ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) + ;; (if (eq? run-id 0) + ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) +;; (db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb) + ;; (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) + ;; (begin + ;; ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db +;; (db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb) + ;; (db:clean-up-rundb (db:get-db fromdb run-id))))) + ;; (set! count (+ count 1)) + ;; (debug:print 0 *default-log-port* "Finished clean up of " + ;; (if (eq? run-id 0) + ;; " main.db " (conc run-id ".db")) ", " count " of " total))))) + ;; all-run-ids)))) + + ;; removed deleted runs +;; (let ((dbdir (tasks:get-task-db-path))) +;; (for-each (lambda (run-id) +;; (let ((fullname (conc dbdir "/" run-id ".db"))) +;; (if (file-exists? fullname) +;; (begin +;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) +;; (delete-file fullname))))) +;; dead-runs)))) +;; + ;; (db:close-all dbstruct) + ;; (sqlite3:finalize! mdb) + ))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* @@ -1370,11 +1434,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1386,11 +1450,11 @@ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1434,11 +1498,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1450,11 +1514,11 @@ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1466,11 +1530,11 @@ (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) ;; (dbexists (file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete @@ -1487,18 +1551,20 @@ (string-intersperse (map conc all-ids) ",") ");"))))) ;; Now do rollups for the toplevel tests ;; - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (for-each (lambda (toptest) (let ((test-name (list-ref toptest 3))) ;; (run-id (list-ref toptest 5))) (db:top-test-set-per-pf-counts dbstruct run-id test-name))) toplevels))) +;; BUG: Probably broken - does not explicitly use run-id in the query +;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) (db:general-call (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) ;; Clean out old junk and vacuum the database @@ -1529,11 +1595,11 @@ ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1543,11 +1609,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1570,11 +1636,11 @@ ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1584,11 +1650,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1617,11 +1683,11 @@ (sqlite3:for-each-row (lambda (run-id) (set! dead-runs (cons run-id dead-runs))) db "SELECT id FROM runs WHERE state='deleted';") - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) @@ -1631,11 +1697,11 @@ (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S @@ -1789,23 +1855,23 @@ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 *default-log-port* "qry: " qry) qry) qryvals) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) @@ -1854,11 +1920,11 @@ (vector header res))) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) - (let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir")) + (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates @@ -1993,11 +2059,11 @@ (totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats @@ -2090,11 +2156,11 @@ (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") @@ -2118,15 +2184,15 @@ ;; First set any related tests to DELETED (let* ((rdbdat (db:get-db dbstruct run-id)) (rdb (db:dbdat-get-db rdbdat)) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy rdbdat) + ;; (db:delay-if-busy rdbdat) (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") (sqlite3:execute rdb "DELETE FROM test_steps;") (sqlite3:execute rdb "DELETE FROM test_data;") - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct @@ -2151,11 +2217,11 @@ (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) @@ -2185,11 +2251,11 @@ (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) @@ -2202,11 +2268,11 @@ (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) @@ -2411,10 +2477,11 @@ (db:general-call dbdat 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) (db:general-call dbdat 'delete-test-data-records (list test-id)) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) +;; (define (db:delete-old-deleted-test-records dbstruct) (let ((run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (for-each (lambda (run-id) @@ -2473,11 +2540,11 @@ (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment) test-id)))) (mt:process-triggers run-id test-id newstate newstatus)))) -;; NEW BEHAVIOR: Count tests running in only one run! +;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) (db:with-db dbstruct run-id @@ -2537,11 +2604,11 @@ (db (db:dbdat-get-db dbdat))) (if (not jobgroup) 0 ;; (let ((testnames '())) ;; get the testnames - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (testname) (set! testnames (cons testname testnames))) db "SELECT testname FROM test_meta WHERE jobgroup=?" @@ -2583,13 +2650,13 @@ run-id #f (lambda (db) (db:first-result-default db - "SELECT id FROM tests WHERE testname=? AND item_path=?;" + "SELECT id FROM tests WHERE testname=? AND item_path=? AND run_id=?;" #f ;; the default - testname item-path)))) + testname item-path run-id)))) ;; overload the unused attemptnum field for the process id of the runscript or ;; ezsteps step script in progress ;; (define (db:test-set-top-process-pid dbstruct run-id test-id pid) @@ -2640,11 +2707,11 @@ (let* ((dbdat (if (vector? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; still settling on when to use dbstruct or dbdat (db (db:dbdat-get-db dbdat)) (res '())) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) res))) @@ -2746,11 +2813,11 @@ db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) -(define (db:get-test-info dbstruct run-id testname item-path) +(define (db:get-test-info dbstruct run-id test-name item-path) (db:with-db dbstruct run-id #f (lambda (db) @@ -2757,12 +2824,12 @@ (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") - test-name item-path) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") + test-name item-path run-id) res)))) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (db:with-db dbstruct @@ -2835,11 +2902,11 @@ (define (db:test-data-rollup dbstruct run-id test-id status) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (fail-count 0) (pass-count 0)) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db @@ -2985,11 +3052,11 @@ ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:execute db "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))) ;; This routine moved from tdb.scm, tdb:read-test-data @@ -2996,11 +3063,11 @@ ;; (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (res '())) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (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))) db "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) @@ -3104,38 +3171,102 @@ (if msg (db:general-call dbdat 'state-status-msg (list state status msg test-id)) (db:general-call dbdat 'state-status (list state status test-id))) (mt:process-triggers run-id test-id state status))) +;; state is the priority rollup of all states +;; status is the priority rollup of all completed states +;; +;; if test-name is an integer work off that instead of test-name test-path +;; +(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status #!key (comment #f)) + (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) + (testdat1 (if (number? test-name) + (db:get-test-info-by-id dbstruct run-id test-name) + #f)) + (orig-test-id (if testdat1 (db:test-get-id testdat1) #f)) ;; the item + (test-name (if testdat1 (db:test-get-testname testdat1) test-name)) + (testdat (db:get-test-info dbstruct run-id test-name "")) + (test-id (db:test-get-id testdat)) + (item-path (db:test-get-item-path (or testdat1 testdat)))) + (print "Got here.") + (sqlite3:with-transaction + db + (lambda () + (if orig-test-id (db:test-set-state-status-by-id dbstruct run-id orig-test-id state status comment)) + (if (not (equal? item-path "")) ;; only roll up IF we are an item + (let* ((all-curr-states (common:special-sort + (delete-duplicates + (let ((states (db:get-all-item-states db run-id test-name))) + (if state (cons state states) states))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort + (delete-duplicates + (let ((statuses (db:get-all-item-statuses db run-id test-name))) + (if (equal? state "COMPLETED") + (cons status statuses) + statuses))) + *common:std-statuses* >)) + (newstate (if (null? all-curr-states) "NOT_STARTED" (car all-curr-states))) + (newstatus (if (null? all-curr-statuses) "n/a" (car all-curr-statuses)))) + (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus #f))))))) + +(define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items) + ;; call with state = #f to roll up with out accounting for state/status of this item ;; -(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) - (if (not (equal? item-path "")) - (let ((dbdat (db:get-db dbstruct run-id))) - ;; (db (db:dbdat-get-db dbdat))) - (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) - (db:top-test-set-per-pf-counts dbstruct run-id test-name)))) - -;; (case (string->symbol status) -;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) - -;; (if (or (not state) -;; (not (equal? item-path ""))) -;; ;; just do a rollup -;; (begin -;; (db:top-test-set-per-pf-counts dbdat run-id test-name) -;; #f) -;; (begin -;; ;; NOTE: No else clause needed for this case -;; (case (string->symbol status) -;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) -;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) -;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) -;; #f) -;; ))) +;; (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) +;; (if (not (equal? item-path "")) ;; if asked to do this for a specific item then do an incremental update +;; (let* ((dbdat (db:get-db dbstruct run-id)) +;; (toptestdat (db:get-test-info dbstruct run-id test-name item-path)) +;; (currtopstate (db:test-get-state toptestdat)) +;; (currtopstatus (db:test-get-status toptestdat)) +;; (nextss (common:apply-state-status currtopstate currtopstatus state status)) +;; (newtopstate (car nextss)) ;; #f or a symbol +;; (newtopstatus (cdr nextss))) ;; #f or a symbol +;; (if (not newtopstate) ;; need to calculate it +;; +;; ;; We rely on the toplevel to track status as state varies. I.e. preserve an ABORT +;; +;; +;; ;; (db (db:dbdat-get-db dbdat))) +;; (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) +;; (db:top-test-set-per-pf-counts dbstruct run-id test-name)))) +;; +;; ;; (case (string->symbol status) +;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) +;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) +;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) +;; +;; ;; (if (or (not state) +;; ;; (not (equal? item-path ""))) +;; ;; ;; just do a rollup +;; ;; (begin +;; ;; (db:top-test-set-per-pf-counts dbdat run-id test-name) +;; ;; #f) +;; ;; (begin +;; ;; ;; NOTE: No else clause needed for this case +;; ;; (case (string->symbol status) +;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) +;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) +;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) +;; ;; #f) +;; ;; ))) + +(define (db:get-all-item-states db run-id test-name) + (sqlite3:map-row + (lambda (a) a) + db + "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" + run-id test-name)) + +(define (db:get-all-item-statuses db run-id test-name) + (sqlite3:map-row + (lambda (a) a) + db + "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?" + run-id test-name)) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id @@ -3150,11 +3281,11 @@ (set! res (list path final_logf)) (if (directory? path) (debug:print 2 *default-log-port* "Found path: " path) (debug:print 2 *default-log-port* "No such path: " path))) ;; ) db - "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" + "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;" test-name) res)))) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S @@ -3184,11 +3315,11 @@ ELSE status END WHERE id=?;") ;; DONE '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE - '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;") + '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;") ;; BROKEN!!! NEEDS run-id '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE "UPDATE tests SET state='DELETED' WHERE state=?") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE @@ -3196,13 +3327,13 @@ '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-pass-fail-counts "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE testname=? AND item_path='';") ;; DONE - '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE - '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE + WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id + '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this: ;; ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status; @@ -3288,11 +3419,11 @@ AND item_path != '' AND state = 'COMPLETED' AND status = 'PASS') > 0 THEN 'PASS' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END - WHERE testname=? AND item_path='';") ;; DONE + WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id ;; 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 )) @@ -3328,11 +3459,11 @@ (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) - (db:delay-if-busy dbdat) + ;; (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 ;; @@ -3386,11 +3517,11 @@ (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) ADDED docs/inprogress/graph-draw-arch.fig Index: docs/inprogress/graph-draw-arch.fig ================================================================== --- /dev/null +++ docs/inprogress/graph-draw-arch.fig @@ -0,0 +1,52 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +6 5700 3075 8400 3675 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5700 3075 8400 3075 8400 3675 5700 3675 5700 3075 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 9 + 5700 3525 5925 3525 5925 3225 6750 3225 6750 3450 7350 3450 + 7350 3600 8325 3600 8250 3525 +-6 +6 7425 6825 10125 7425 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7425 6825 10125 6825 10125 7425 7425 7425 7425 6825 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 9 + 7425 7275 7650 7275 7650 6975 8475 6975 8475 7200 9075 7200 + 9075 7350 10050 7350 9975 7275 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 3000 4650 3000 3225 600 3225 600 4650 3000 4650 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2550 5100 2550 3675 150 3675 150 5100 2550 5100 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3000 3825 5550 3450 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5475 2400 8475 2400 8475 4650 5475 4650 5475 2400 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 7275 4725 8175 6375 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 1 + 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6225 6300 11025 6300 11025 9000 6225 9000 6225 6300 +2 4 2 1 0 7 50 -1 -1 3.000 0 0 7 0 0 5 + 8850 5850 8850 900 75 900 75 5850 8850 5850 +2 4 0 1 0 7 50 -1 -1 3.000 0 0 7 0 0 5 + 4875 5550 4875 4500 3450 4500 3450 5550 4875 5550 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 4500 4500 5475 4200 +4 0 0 50 -1 0 12 0.0000 4 195 915 750 3525 graph data\001 +4 0 0 50 -1 0 12 0.0000 4 195 525 5550 2700 layout\001 +4 0 0 50 -1 0 12 0.0000 4 195 1800 6375 6525 display on dashboard\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 3525 4875 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 6150 675 1425 Very slow! Threaded running of procedure: runtimes-tab-layout-updater\001 +4 0 0 50 -1 0 12 0.0000 4 195 2865 8325 6225 fast!runtimes-tab-canvas-updater\001 ADDED docs/inprogress/megatest-architecture-proposed-2.fig Index: docs/inprogress/megatest-architecture-proposed-2.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture-proposed-2.fig @@ -0,0 +1,490 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +6 600 1350 1575 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1125 1500 450 150 1125 1500 1575 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1124 2177 450 150 1124 2177 1574 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 675 1575 675 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1575 1500 1575 2175 +-6 +6 1875 825 2850 1875 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2400 975 450 150 2400 975 2850 1125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2399 1652 450 150 2399 1652 2849 1802 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1950 1050 1950 1650 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2850 975 2850 1650 +-6 +6 3225 450 4200 1500 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 600 450 150 3750 600 4200 750 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3749 1277 450 150 3749 1277 4199 1427 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3300 675 3300 1275 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4200 600 4200 1275 +-6 +6 3075 2925 4050 3975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3600 3075 450 150 3600 3075 4050 3225 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3599 3752 450 150 3599 3752 4049 3902 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3150 3150 3150 3750 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4050 3075 4050 3750 +-6 +6 7275 4050 12825 9675 +6 8175 4125 8400 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4125 8400 4125 8400 4350 8175 4350 8175 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4350 8400 4350 8400 4575 8175 4575 8175 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4575 8400 4575 8400 4800 8175 4800 8175 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4800 8400 4800 8400 5025 8175 5025 8175 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5025 8400 5025 8400 5250 8175 5250 8175 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5250 8400 5250 8400 5475 8175 5475 8175 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5475 8400 5475 8400 5700 8175 5700 8175 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5700 8400 5700 8400 5925 8175 5925 8175 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5925 8400 5925 8400 6150 8175 6150 8175 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6150 8400 6150 8400 6375 8175 6375 8175 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6375 8400 6375 8400 6600 8175 6600 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6600 8400 6600 8400 6825 8175 6825 8175 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6825 8400 6825 8400 7050 8175 7050 8175 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7050 8400 7050 8400 7275 8175 7275 8175 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7275 8400 7275 8400 7500 8175 7500 8175 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7500 8400 7500 8400 7725 8175 7725 8175 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7725 8400 7725 8400 7950 8175 7950 8175 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7950 8400 7950 8400 8175 8175 8175 8175 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8175 8400 8175 8400 8400 8175 8400 8175 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8400 8400 8400 8400 8625 8175 8625 8175 8400 +-6 +6 8475 4125 8700 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4125 8700 4125 8700 4350 8475 4350 8475 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4350 8700 4350 8700 4575 8475 4575 8475 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4575 8700 4575 8700 4800 8475 4800 8475 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4800 8700 4800 8700 5025 8475 5025 8475 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5025 8700 5025 8700 5250 8475 5250 8475 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5250 8700 5250 8700 5475 8475 5475 8475 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5475 8700 5475 8700 5700 8475 5700 8475 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5700 8700 5700 8700 5925 8475 5925 8475 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5925 8700 5925 8700 6150 8475 6150 8475 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6150 8700 6150 8700 6375 8475 6375 8475 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6375 8700 6375 8700 6600 8475 6600 8475 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6600 8700 6600 8700 6825 8475 6825 8475 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6825 8700 6825 8700 7050 8475 7050 8475 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7050 8700 7050 8700 7275 8475 7275 8475 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7275 8700 7275 8700 7500 8475 7500 8475 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7500 8700 7500 8700 7725 8475 7725 8475 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7725 8700 7725 8700 7950 8475 7950 8475 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7950 8700 7950 8700 8175 8475 8175 8475 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8175 8700 8175 8700 8400 8475 8400 8475 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8400 8700 8400 8700 8625 8475 8625 8475 8400 +-6 +6 8775 4125 9000 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4125 9000 4125 9000 4350 8775 4350 8775 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4350 9000 4350 9000 4575 8775 4575 8775 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4575 9000 4575 9000 4800 8775 4800 8775 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4800 9000 4800 9000 5025 8775 5025 8775 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5025 9000 5025 9000 5250 8775 5250 8775 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5250 9000 5250 9000 5475 8775 5475 8775 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5475 9000 5475 9000 5700 8775 5700 8775 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5700 9000 5700 9000 5925 8775 5925 8775 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5925 9000 5925 9000 6150 8775 6150 8775 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6150 9000 6150 9000 6375 8775 6375 8775 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6375 9000 6375 9000 6600 8775 6600 8775 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6600 9000 6600 9000 6825 8775 6825 8775 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6825 9000 6825 9000 7050 8775 7050 8775 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7050 9000 7050 9000 7275 8775 7275 8775 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7275 9000 7275 9000 7500 8775 7500 8775 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7500 9000 7500 9000 7725 8775 7725 8775 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7725 9000 7725 9000 7950 8775 7950 8775 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7950 9000 7950 9000 8175 8775 8175 8775 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8175 9000 8175 9000 8400 8775 8400 8775 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8400 9000 8400 9000 8625 8775 8625 8775 8400 +-6 +6 9075 4125 9300 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4125 9300 4125 9300 4350 9075 4350 9075 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4350 9300 4350 9300 4575 9075 4575 9075 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4575 9300 4575 9300 4800 9075 4800 9075 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4800 9300 4800 9300 5025 9075 5025 9075 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5025 9300 5025 9300 5250 9075 5250 9075 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5250 9300 5250 9300 5475 9075 5475 9075 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5475 9300 5475 9300 5700 9075 5700 9075 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5700 9300 5700 9300 5925 9075 5925 9075 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5925 9300 5925 9300 6150 9075 6150 9075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6150 9300 6150 9300 6375 9075 6375 9075 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6375 9300 6375 9300 6600 9075 6600 9075 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6600 9300 6600 9300 6825 9075 6825 9075 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6825 9300 6825 9300 7050 9075 7050 9075 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7050 9300 7050 9300 7275 9075 7275 9075 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7275 9300 7275 9300 7500 9075 7500 9075 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7500 9300 7500 9300 7725 9075 7725 9075 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7725 9300 7725 9300 7950 9075 7950 9075 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7950 9300 7950 9300 8175 9075 8175 9075 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8175 9300 8175 9300 8400 9075 8400 9075 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8400 9300 8400 9300 8625 9075 8625 9075 8400 +-6 +6 9375 4125 9600 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4125 9600 4125 9600 4350 9375 4350 9375 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4350 9600 4350 9600 4575 9375 4575 9375 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4575 9600 4575 9600 4800 9375 4800 9375 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4800 9600 4800 9600 5025 9375 5025 9375 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5025 9600 5025 9600 5250 9375 5250 9375 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5250 9600 5250 9600 5475 9375 5475 9375 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5475 9600 5475 9600 5700 9375 5700 9375 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5700 9600 5700 9600 5925 9375 5925 9375 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5925 9600 5925 9600 6150 9375 6150 9375 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6150 9600 6150 9600 6375 9375 6375 9375 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6375 9600 6375 9600 6600 9375 6600 9375 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6600 9600 6600 9600 6825 9375 6825 9375 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6825 9600 6825 9600 7050 9375 7050 9375 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7050 9600 7050 9600 7275 9375 7275 9375 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7275 9600 7275 9600 7500 9375 7500 9375 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7500 9600 7500 9600 7725 9375 7725 9375 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7725 9600 7725 9600 7950 9375 7950 9375 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7950 9600 7950 9600 8175 9375 8175 9375 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8175 9600 8175 9600 8400 9375 8400 9375 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8400 9600 8400 9600 8625 9375 8625 9375 8400 +-6 +# Dimension line: 1-1/16 in +6 7875 9375 9150 9675 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7875 9525 9150 9525 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 8085 9375 8085 9675 8939 9675 8939 9375 8085 9375 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7875 9375 7875 9675 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 9150 9375 9150 9675 +4 1 0 48 -1 0 12 -0.0000 4 180 735 8512 9585 1-1/16 in\001 +-6 +# Dimension line: 1-11/16 in +6 7425 4125 7725 6150 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7575 4125 7575 6150 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 7425 5617 7725 5617 7725 4657 7425 4657 7425 5617 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 6150 7725 6150 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 4125 7725 4125 +4 1 0 48 -1 0 12 1.5708 4 180 840 7635 5137 1-11/16 in\001 +-6 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 +2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 +4 0 0 50 -1 0 12 0.0000 4 150 150 8475 9300 X\001 +4 0 0 50 -1 0 12 0.0000 4 150 135 7275 6975 Y\001 +-6 +6 14100 150 19950 6075 +6 14850 1350 15825 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 1575 14925 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 1500 15825 2175 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 3375 15525 2400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 4050 16350 5325 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 4050 17850 4800 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 3750 18375 4125 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 3900 18075 2625 15900 1875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 150 19950 150 19950 6075 14100 6075 14100 150 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 +-6 +6 14850 7425 15825 8475 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 7650 14925 8250 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 7575 15825 8250 +-6 +6 17775 6675 18750 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 17850 6900 17850 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 18750 6825 18750 7500 +-6 +6 4875 6075 5850 7125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5400 6225 450 150 5400 6225 5850 6375 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5399 6902 450 150 5399 6902 5849 7052 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4950 6300 4950 6900 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5850 6225 5850 6900 +-6 +6 5400 7425 7350 8925 +6 5475 7650 6450 8700 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 7800 450 150 6000 7800 6450 7950 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5999 8477 450 150 5999 8477 6449 8627 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5550 7875 5550 8475 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 6450 7800 6450 8475 +-6 +4 0 0 50 -1 0 12 0.0000 4 195 1905 5400 8850 pointers to the servers\001 +4 0 0 50 -1 0 12 0.0000 4 150 930 5550 7575 monitor.db\001 +-6 +6 6150 2700 7500 3225 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700 +4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1725 5025 1275 2475 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5550 4500 5550 225 225 225 225 4500 5550 4500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1875 7725 1875 5775 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1425 7725 2775 7725 2775 8250 1425 8250 1425 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3375 7725 4725 7725 4725 8250 3375 8250 3375 7725 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3675 7725 2175 5775 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2775 5700 2775 5100 1500 5100 1500 5700 2775 5700 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6600 3300 2925 5025 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 10125 17025 9525 15750 9525 15750 10125 17025 10125 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 9450 15525 8475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 11400 17175 11400 17175 11925 15825 11925 15825 11400 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 10125 16350 11400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 10875 18900 10875 18900 11400 17550 11400 17550 10875 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 9975 19725 9975 19725 10500 18375 10500 18375 9975 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 10125 17850 10875 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 9825 18375 10200 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 9975 18075 8700 15900 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 6225 19950 6225 19950 12150 14100 12150 14100 6225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16575 9375 17850 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2100 10425 6150 10425 6150 14400 2100 14400 2100 10425 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2325 10875 5925 10875 5925 13800 2325 13800 2325 10875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2400 10950 3975 10950 3975 11625 2400 11625 2400 10950 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5325 12675 5325 12075 4050 12075 4050 12675 5325 12675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3975 11250 4575 12075 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2175 5025 3075 3750 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4800 6375 2850 5550 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3600 2475 7425 6525 +4 0 0 50 -1 0 12 0.0000 4 195 990 1800 2625 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 150 690 3150 4125 main.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 4200 3600 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 195 330 1950 6825 http\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 1575 7950 run1/test1\001 +4 0 0 50 -1 0 12 0.0000 4 150 720 1650 5400 server-1\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 2175 2025 2.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 750 2550 1.db\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 3450 7950 run1/test2\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 9675 3750 Dashboardm\001 +4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1305 17700 7875 mysql/postgres\001 +4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001 +4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001 +4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001 +4 0 0 50 -1 0 12 0.0000 4 195 2205 450 525 /tmp//??? /.db/*.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 4800 7350 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1785 600 8775 Possible Future state\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 8025 450 CHANGES:\001 +4 0 0 50 -1 0 12 0.0000 4 195 2145 8025 705 1. http -> rcp or nanomsg\001 +4 0 0 50 -1 0 12 0.0000 4 195 3330 8025 960 2. cache db moves from inmem to /tmp\001 Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -429,14 +429,14 @@ (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers (if (equal? new-server-id server-id) (begin (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access - (set! *inmemdb* (db:setup run-id)) + (set! *inmemdb* (db:setup)) ;; run-id)) ;; force initialization ;; (db:get-db *inmemdb* #t) - (db:get-db *inmemdb* run-id) + ;; (db:get-db *inmemdb* run-id) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")) (begin ;; gotta exit nicely (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision") (http-transport:server-shutdown server-id port)))))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -240,11 +240,11 @@ ;; Since we should have a clean slate at this time there is no need to do ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a ;; (thread-sleep! 0.3) - (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") + ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -141,10 +141,11 @@ -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -import-megatest.db : migrate a database from v1.55 series to v1.60 series -sync-to-megatest.db : migrate data back to megatest.db + -use-db-cache : use cached access to db to reduce load -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname @@ -259,12 +260,14 @@ "-archive" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" - ) - (list "-h" "-help" "--help" + "-target-db" + "-source-db" + ) + (list "-h" "-help" "--help" "-manual" "-version" "-force" "-xterm" "-showkeys" @@ -277,11 +280,12 @@ "-daemonize" "-preclean" "-rerun-clean" "-rerun-all" "-clean-cache" - + "-cache-db" + "-use-db-cache" ;; misc "-repl" "-lock" "-unlock" "-list-servers" @@ -339,11 +343,10 @@ (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; -(define *time-zero* (current-seconds)) (define *watchdog* (make-thread (lambda () (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:legacy-sync-required)) @@ -351,31 +354,12 @@ (last-time (current-seconds))) (if (common:legacy-sync-recommended) (let loop () ;; sync for filesystem local db writes ;; - (let ((start-time (current-seconds)) - (servers-started (make-hash-table))) - (for-each - (lambda (run-id) - (mutex-lock! *db-multi-sync-mutex*) - (if (and legacy-sync - (hash-table-ref/default *db-local-sync* run-id #f)) - ;; (if (> (- start-time last-write) 5) ;; every five seconds - (begin ;; let ((sync-time (- (current-seconds) start-time))) - (db:multi-db-sync (list run-id) 'new2old) - (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") - (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) - ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run - ;; (begin - ;; (debug:print-info 0 *default-log-port* "Sync is taking a long time, start up a server to assist for run " run-id) - ;; (server:kind-run run-id))))) - (hash-table-delete! *db-local-sync* run-id))) - (mutex-unlock! *db-multi-sync-mutex*)) - (hash-table-keys *db-local-sync*)) + (let ((start-time (current-seconds))) + ;; disabling for now (if legacy-sync (common:sync-to-megatest.db #f)) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) @@ -480,10 +464,18 @@ (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== + +(if (and (args:get-arg "-cache-db") + (args:get-arg "-source-db")) + (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) + (target-db (conc temp-dir "/cached.db")) + (source-db (args:get-arg "-source-db"))) + (db:cache-for-read-only source-db target-db) + (set! *didsomething* #t))) ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") (begin @@ -1038,11 +1030,11 @@ (define (get-value-by-fieldname datavec test-field-index fieldname) (let ((indx (hash-table-ref/default test-field-index fieldname #f))) (if indx (if (>= indx (vector-length datavec)) - #f ;; index to high, should raise an error I suppose + #f ;; index too high, should raise an error I suppose (vector-ref datavec indx)) #f))) ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; @@ -1051,18 +1043,21 @@ (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup) (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) (runpatt (args:get-arg "-list-runs")) + (access-mode (db:get-access-mode)) (testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) - ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) - (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) - #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runsdat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt keys (or runpatt "%") + (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) ;; this is "-since" support. This looks at last mod times of .db files ;; and collects those modified since the -since time. (runs (if (and (not (null? runstmp)) @@ -1128,11 +1123,11 @@ (let* ((run-id (db:get-value-by-header run header "id")) (runname (db:get-value-by-header run header "runname")) (states (string-split (or (args:get-arg "-state") "") ",")) (statuses (string-split (or (args:get-arg "-status") "") ",")) (tests (if tests-spec - (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc ;; use qryvals if test-spec provided (if tests-spec (string-intersperse adj-tests-spec ",") ;; db:test-record-fields #f) @@ -1253,11 +1248,11 @@ ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* ;; (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run - (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (let ((steps (db:dispatch-query access-mode rmt:get-steps-for-test db:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -36,39 +36,17 @@ ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== -;; -(define (rmt:write-frequency-over-limit? cmd run-id) - (and (not (member cmd api:read-only-queries)) - (let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f)) - (record (if tmprec tmprec - (let ((v (vector (current-seconds) 0))) - (hash-table-set! *write-frequency* run-id v) - v))) - (count (+ 1 (vector-ref record 1))) - (start (vector-ref record 0)) - (queries-per-second (/ (* count 1.0) - (max (- (current-seconds) start) 1)))) - (vector-set! record 1 count) - (if (and (> count 10) - (> queries-per-second 10)) - (begin - (debug:print-info 1 *default-log-port* "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) - #t) - #f)))) - ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; (define (rmt:get-connection-info run-id) (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) (if cinfo cinfo - ;; NB// can cache the answer for server running for 10 seconds ... - ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id @@ -76,102 +54,112 @@ ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; clean out old connections ;; (mutex-lock! *db-multi-sync-mutex*) - (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin - (for-each - (lambda (run-id) - (let ((connection (hash-table-ref/default *runremote* run-id #f))) - (if (and (vector? connection) - (< (http-transport:server-dat-get-last-access connection) expire-time)) - (begin - (debug:print-info 0 *default-log-port* "Discarding connection to server for run-id " run-id ", too long between accesses") - ;; bb- disabling nanomsg - ;; SHOULD CLOSE THE CONNECTION HERE - ;; (case *transport-type* - ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket - ;; (hash-table-ref *runremote* run-id))))) - (hash-table-delete! *runremote* run-id))))) - (hash-table-keys *runremote*))) - ;; (mutex-unlock! *db-multi-sync-mutex*) - ;; (mutex-lock! *send-receive-mutex*) - (let* ((run-id (if rid rid 0)) - (connection-info (rmt:get-connection-info run-id))) - ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) - (if connection-info - ;; use the server if have connection info - (let* ((dat (case *transport-type* - ((http)(condition-case - (http-transport:client-api-send-receive run-id connection-info cmd params) - ((commfail)(vector #f "communications fail")) - ((exn)(vector #f "other fail")))) - ;; ((nmsg)(condition-case - ;; (nmsg-transport:client-api-send-receive run-id connection-info cmd params) - ;; ((timeout)(vector #f "timeout talking to server")))) - (else (exit)))) - (success (if (vector? dat) (vector-ref dat 0) #f)) - (res (if (vector? dat) (vector-ref dat 1) #f))) - (if (vector? connection-info)(http-transport:server-dat-update-last-access connection-info)) - (if success - (begin - ;; (mutex-unlock! *send-receive-mutex*) - (case *transport-type* - ((http) res) ;; (db:string->obj res)) - ;; ((nmsg) res) - )) ;; (vector-ref res 1))) - (begin ;; let ((new-connection-info (client:setup run-id))) - (debug:print 0 *default-log-port* "WARNING: Communication failed, trying call to rmt:send-receive again.") - ;; (case *transport-type* - ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info)))) - (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection - ;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. - ;; (if (eq? (modulo attemptnum 5) 0) - ;; (tasks:kill-server-run-id run-id tag: "api-send-receive-failed")) - ;; (mutex-unlock! *send-receive-mutex*) ;; close the mutex here to allow other threads access to communications - (tasks:start-and-wait-for-server (tasks:open-db) run-id 15) - ;; (nmsg-transport:client-api-send-receive run-id connection-info cmd param remtries: (- remtries 1)))))) - - ;; no longer killing the server in http-transport:client-api-send-receive - ;; may kill it here but what are the criteria? - ;; start with three calls then kill server - ;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) - ;; (thread-sleep! 2) - (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))))) - ;; no connection info? try to start a server, or access locally if no - ;; server and the query is read-only - ;; - ;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call - ;; - (if (and (< attemptnum 15) - (member cmd api:write-queries)) - (let ((faststart (configf:lookup *configdat* "server" "faststart"))) - (hash-table-delete! *runremote* run-id) - ;; (mutex-unlock! *send-receive-mutex*) - (if (and faststart (equal? faststart "no")) - (begin - (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) - (thread-sleep! (random 5)) ;; give some time to settle and minimize collison? - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) - (let ((start-time (current-milliseconds)) - (max-query (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") - "300"))) - (newres (rmt:open-qry-close-locally cmd run-id params))) - (let ((delta (- (current-milliseconds) start-time))) - (if (> delta max-query) - (begin - (debug:print-info 0 *default-log-port* "Starting server as query time " delta " is over the limit of " max-query) - (server:kind-run run-id))) - ;; return the result! - newres) - ))) - (begin - ;; (debug:print-error 0 *default-log-port* "Communication failed!") - ;; (mutex-unlock! *send-receive-mutex*) - ;; (exit) - (rmt:open-qry-close-locally cmd run-id params) - ))))) + (rmt:open-qry-close-locally cmd (if rid rid 0) params)) + +;; (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin +;; (for-each +;; (lambda (run-id) +;; (let ((connection (hash-table-ref/default *runremote* run-id #f))) +;; (if (and (vector? connection) +;; (< (http-transport:server-dat-get-last-access connection) expire-time)) +;; (begin +;; (debug:print-info 0 *default-log-port* "Discarding connection to server for run-id " run-id ", too long between accesses") +;; ;; bb- disabling nanomsg +;; ;; SHOULD CLOSE THE CONNECTION HERE +;; ;; (case *transport-type* +;; ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket +;; ;; (hash-table-ref *runremote* run-id))))) +;; (hash-table-delete! *runremote* run-id))))) +;; (hash-table-keys *runremote*))) +;; ;; (mutex-unlock! *db-multi-sync-mutex*) +;; ;; (mutex-lock! *send-receive-mutex*) +;; (let* ((run-id (if rid rid 0)) +;; (home-host (common:get-homehost)) +;; (connection-info (if (cdr home-host) ;; we are on the home-host +;; #f +;; (rmt:get-connection-info run-id)))) +;; (cond +;; (home-host (rmt:open-qry-close-locally cmd run-id params)) +;; (connection-info +;; ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) +;; ;; use the server if have connection info +;; (let* ((dat (case *transport-type* +;; ((http)(condition-case +;; (http-transport:client-api-send-receive run-id connection-info cmd params) +;; ((commfail)(vector #f "communications fail")) +;; ((exn)(vector #f "other fail")))) +;; ;; ((nmsg)(condition-case +;; ;; (nmsg-transport:client-api-send-receive run-id connection-info cmd params) +;; ;; ((timeout)(vector #f "timeout talking to server")))) +;; (else (exit)))) +;; (success (if (vector? dat) (vector-ref dat 0) #f)) +;; (res (if (vector? dat) (vector-ref dat 1) #f))) +;; (if (vector? connection-info)(http-transport:server-dat-update-last-access connection-info)) +;; (if success +;; (begin +;; ;; (mutex-unlock! *send-receive-mutex*) +;; (case *transport-type* +;; ((http) res) ;; (db:string->obj res)) +;; ;; ((nmsg) res) +;; )) ;; (vector-ref res 1))) +;; (begin ;; let ((new-connection-info (client:setup run-id))) +;; (debug:print 0 *default-log-port* "WARNING: Communication failed, trying call to rmt:send-receive again.") +;; ;; (case *transport-type* +;; ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info)))) +;; (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection +;; ;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. +;; ;; (if (eq? (modulo attemptnum 5) 0) +;; ;; (tasks:kill-server-run-id run-id tag: "api-send-receive-failed")) +;; ;; (mutex-unlock! *send-receive-mutex*) ;; close the mutex here to allow other threads access to communications +;; (tasks:start-and-wait-for-server (tasks:open-db) run-id 15) +;; ;; (nmsg-transport:client-api-send-receive run-id connection-info cmd param remtries: (- remtries 1)))))) +;; +;; ;; no longer killing the server in http-transport:client-api-send-receive +;; ;; may kill it here but what are the criteria? +;; ;; start with three calls then kill server +;; ;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) +;; ;; (thread-sleep! 2) +;; (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1)))))) +;; (else +;; ;; no connection info? try to start a server, or access locally if no +;; ;; server and the query is read-only +;; ;; +;; ;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call +;; ;; +;; (if (and (< attemptnum 15) +;; (member cmd api:write-queries)) +;; (let ((homehost (common:get-homehost))) ;; faststart (configf:lookup *configdat* "server" "faststart"))) +;; (hash-table-delete! *runremote* run-id) +;; ;; (mutex-unlock! *send-receive-mutex*) +;; (if (not (cdr homehost)) ;; we always require a server if not on homehost ;; (and faststart (equal? faststart "no")) +;; (begin +;; (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) +;; (thread-sleep! (random 5)) ;; give some time to settle and minimize collison? +;; (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) +;; ;; NB - probably can remove the query time stuff but need to discuss it .... +;; (let ((start-time (current-milliseconds)) +;; (max-query (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") +;; "300"))) +;; (newres (rmt:open-qry-close-locally cmd run-id params))) +;; (let ((delta (- (current-milliseconds) start-time))) +;; (if (> delta max-query) +;; (begin +;; (debug:print-info 0 *default-log-port* "WARNING: long query times, you may have an overloaded homehost.") ;; Starting server as query time " delta " is over the limit of " max-query) +;; ;; (server:kind-run run-id))) +;; )) +;; ;; return the result! +;; newres) +;; ))) +;; (begin +;; ;; (debug:print-error 0 *default-log-port* "Communication failed!") +;; ;; (mutex-unlock! *send-receive-mutex*) +;; ;; (exit) +;; (rmt:open-qry-close-locally cmd run-id params) +;; )))))) (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn @@ -227,18 +215,27 @@ (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) - (let* ((dbstruct-local (db:open-local-db-handle)) - (db-file-path (db:dbfile-path 0)) - ;; (read-only (not (file-read-access? db-file-path))) + (let* ((qry-is-write (not (member cmd api:read-only-queries))) + (db-file-path (db:dbfile-path)) ;; 0)) + (dbstruct-local (if *dbstruct-db* + *dbstruct-db* + (let* ((db (db:setup))) ;; make-dbr:dbstruct path: dbdir local: #t))) + (set! *dbstruct-db* db) + db))) + (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) - (resdat (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))) + (resdat (if (not (and read-only qry-is-write)) + (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)) + (vector #t '()))) (success (vector-ref resdat 0)) (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) + (if (and read-only qry-is-write) + (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay @@ -247,18 +244,16 @@ (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write - (if (not (member cmd api:read-only-queries)) + (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) - ;; (if (not (hash-table-ref/default *db-local-sync* run-id #f)) - ;; just set it every time. Is a write more expensive than a read and does it matter? (hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write" - (mutex-unlock! *db-multi-sync-mutex*))) - res)))) + (mutex-unlock! *db-multi-sync-mutex*))))) + res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) ;; (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) (res (handle-exceptions Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -222,11 +222,11 @@ ;; override the number of reruns from the configs (if (and config-reruns (> run-count config-reruns)) (set! run-count config-reruns)) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -353,10 +353,11 @@ (pop-directory) result))))) (define (tests:test-force-state-status! run-id test-id state status) (rmt:test-set-status-state run-id test-id status state #f) + ;; (rmt:roll-up-pass-fail-counts run-id test-name item (mt:process-triggers run-id test-id state status)) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -44,10 +44,14 @@ # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 + +# wait 0.5 seconds between launching every process +# +launch-delay 0.5 # wait for runs to completely complete. yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses