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
;;
@@ -392,26 +396,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 +500,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 +633,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 +718,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 +1054,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
@@ -415,13 +415,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 +513,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,14 @@
;;======================================================================
;; 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))
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
@@ -86,22 +76,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 +96,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*))))
+;; (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;")
;; 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 +155,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 +185,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 +208,93 @@
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) ;; (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))
+ (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)
+ ;; (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) ;; . 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)
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))
+ (let* ((dbpath (conc (or path *toppath*) "/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 +304,97 @@
(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))
;; (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 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))))
+ (if tdb (sqlite3:finalize! tdb))
+ (if mdb (sqlite3:finalize! mdb))))))
+
+;; (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 +444,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 +468,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 +550,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 +602,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 +694,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)))
@@ -796,141 +771,212 @@
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))
+ (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)
+ (db:clean-up mtdb)
+ (db:clean-up tmpdb)))
+
+ ;; 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))
+ ;; (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 mtdb))
+ ;; (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*
@@ -1854,11 +1900,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
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/<user>/??? /.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: 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 <run-id>.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: 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