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: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -180,18 +180,18 @@
)))
(if (and start-res
ping-res)
(begin
- (hash-table-set! *runremote* run-id start-res)
+ (set! *runremote* start-res) ;; (hash-table-set! *runremote* run-id start-res)
(debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
start-res)
(begin ;; login failed but have a server record, clean out the record and try again
(debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
(case *transport-type*
((http)(http-transport:close-connections run-id)))
- (hash-table-delete! *runremote* run-id)
+ (set! *runremote* #f) ;; (hash-table-delete! *runremote* run-id)
(tasks:kill-server-run-id run-id)
(tasks:server-force-clean-run-record (db:delay-if-busy tdbdat)
run-id
(tasks:hostinfo-get-interface server-dat)
(tasks:hostinfo-get-port server-dat)
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 directory-utils)
(require-extension regex posix)
(require-extension (srfi 18) extras tcp rpc)
(import (prefix sqlite3 sqlite3:))
@@ -43,16 +43,16 @@
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
-(define *contexts* (make-hash-table))
-
-;; Common data structure for
+;; CONTEXTS
(defstruct cxt
(taskdb #f)
(cmutex (make-mutex)))
+(define *contexts* (make-hash-table))
+(define *context-mutex* (make-mutex))
;; safe method for accessing a context given a toppath
;;
(define (common:with-cxt toppath proc)
(mutex-lock! *context-mutex*)
@@ -73,64 +73,70 @@
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
-(define *waiting-queue* (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(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 *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
+;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
-(define *db-sync-mutex* (make-mutex))
-(define *db-multi-sync-mutex* (make-mutex))
-(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db
-(define *megatest-db* #f)
-(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
+;; db access
+(define *db-last-access* (current-seconds)) ;; last db access, used in server
(define *db-write-access* #t)
-(define *inmemdb* #f)
+;; db sync
+(define *db-last-write* 0) ;; used to record last touch of db
+(define *db-last-sync* 0) ;; last time the sync to megatest.db happened
+(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
+(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* and *db-last-write*
+;; task db
(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
-(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
+(define *runremote* #f) ;; if set up for server communication this will hold <host port>
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
-(define *client-non-blocking-mode* #f)
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
-(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 *total-non-write-delay* 0)
+(define *heartbeat-mutex* (make-mutex))
+;; RPC transport
+(define *rpc:listener* #f)
+
+;; KEY info
(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget
-
+(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
+(define *homehost-mutex* (make-mutex))
;; Awful. Please FIXME
(define *env-vars-by-run-id* (make-hash-table))
-(define *current-run-name* #f)
;; Testconfig and runconfig caches.
(define *testconfigs* (make-hash-table)) ;; test-name => testconfig
(define *runconfigs* (make-hash-table)) ;; target => runconfig
@@ -188,46 +194,74 @@
(common:version-signature))))
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
-(define (common:cleanup-db)
+(define (common:cleanup-db dbstruct)
(db:multi-db-sync
- #f ;; do all run-ids
+ dbstruct
;; 'new2old
'killservers
'dejunk
;; 'adj-testids
;; 'old2new
- 'new2old)
+ 'new2old
+ 'schema)
(if (common:version-changed?)
(common:set-last-run-version)))
+
+;; Rotate logs, logic:
+;; if > 500k and older than 1 week:
+;; remove previous compressed log and compress this log
+;; WARNING: This proc operates assuming that it is in the directory above the
+;; logs directory you wish to log-rotate.
+;;
+(define (common:rotate-logs)
+ (if (not (directory-exists? "logs"))(create-directory "logs"))
+ (directory-fold
+ (lambda (file rem)
+ (if (and (string-match "^.*.log" file)
+ (> (file-size (conc "logs/" file)) 200000))
+ (let ((gzfile (conc "logs/" file ".gz")))
+ (if (file-exists? gzfile)
+ (begin
+ (debug:print-info 0 *default-log-port* "removing " gzfile)
+ (delete-file gzfile)))
+ (debug:print-info 0 *default-log-port* "compressing " file)
+ (system (conc "gzip logs/" file)))))
+ '()
+ "logs"))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
(if (common:version-changed?)
- (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")))
- (debug:print 0 *default-log-port*
- "WARNING: Version mismatch!\n"
- " expected: " (common:version-signature) "\n"
- " got: " (common:get-last-run-version))
- (if (and (file-exists? mtconf)
- (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
- (begin
- (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "Failed to switch versions.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))
- (exit 1))
- (common:cleanup-db)))
- (begin
- (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
- (exit 1))))))
+ (if (common:on-homehost?)
+ (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
+ (dbstruct (db:setup)))
+ (debug:print 0 *default-log-port*
+ "WARNING: Version mismatch!\n"
+ " expected: " (common:version-signature) "\n"
+ " got: " (common:get-last-run-version))
+ (if (and (file-exists? mtconf)
+ (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
+ (begin
+ (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "Failed to switch versions.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port))
+ (exit 1))
+ (common:cleanup-db dbstruct)))
+ (begin
+ (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
+ (exit 1))))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
+ (exit 1)))))
;;======================================================================
;; S P A R S E A R R A Y S
;;======================================================================
@@ -345,36 +379,105 @@
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
- '((0 "COMPLETED")
- (1 "NOT_STARTED")
- (2 "RUNNING")
- (3 "REMOTEHOSTSTART")
- (4 "LAUNCHED")
- (5 "KILLED")
- (6 "KILLREQ")
- (7 "STUCK")
- (8 "ARCHIVED")))
+ '((0 "ARCHIVED")
+ (1 "STUCK")
+ (2 "KILLREQ")
+ (3 "KILLED")
+ (4 "NOT_STARTED")
+ (5 "COMPLETED")
+ (6 "LAUNCHED")
+ (7 "REMOTEHOSTSTART")
+ (8 "RUNNING")
+ ))
(define *common:std-statuses*
- '((0 "PASS")
- (1 "WARN")
- (2 "FAIL")
+ '(;; (0 "DELETED")
+ (1 "n/a")
+ (2 "PASS")
(3 "CHECK")
- (4 "n/a")
- (5 "WAIVED")
- (6 "SKIP")
- (7 "DELETED")
- (8 "STUCK/DEAD")
+ (4 "SKIP")
+ (5 "WARN")
+ (6 "WAIVED")
+ (7 "STUCK/DEAD")
+ (8 "FAIL")
(9 "ABORT")))
+
+(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
+ '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
+
+(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
+ '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
+
+(define (common:special-sort items order comp)
+ (let ((items-order (map reverse order))
+ (acomp (or comp >)))
+ (sort items
+ (lambda (a b)
+ (let ((a-num (cadr (or (assoc a items-order) '(0 0))))
+ (b-num (cadr (or (assoc b items-order) '(0 0)))))
+ (acomp a-num b-num))))))
;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym*
'(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED))
+;; given a toplevel with currstate, currstatus apply state and status
+;; => (newstate . newstatus)
+(define (common:apply-state-status currstate currstatus state status)
+ (let* ((cstate (string->symbol (string-downcase currstate)))
+ (cstatus (string->symbol (string-downcase currstatus)))
+ (sstate (string->symbol (string-downcase state)))
+ (sstatus (string->symbol (string-downcase status)))
+ (nstate #f)
+ (nstatus #f))
+ (set! nstate
+ (case cstate
+ ((completed not_started killed killreq stuck archived)
+ (case sstate ;; completed -> sstate
+ ((completed killed killreq stuck archived) completed)
+ ((running remotehoststart launched) running)
+ (else unknown-error-1)))
+ ((running remotehoststart launched)
+ (case sstate
+ ((completed killed killreq stuck archived) #f) ;; need to look at all items
+ ((running remotehoststart launched) running)
+ (else unknown-error-2)))
+ (else unknown-error-3)))
+ (set! nstatus
+ (case sstatus
+ ((pass)
+ (case nstate
+ ((pass n/a deleted) pass)
+ ((warn) warn)
+ ((fail) fail)
+ ((check) check)
+ ((waived) waived)
+ ((skip) skip)
+ ((stuck/dead) stuck)
+ ((abort) abort)
+ (else unknown-error-4)))
+ ((warn)
+ (case nstate
+ ((pass warn n/a skip deleted) warn)
+ ((fail) fail)
+ ((check) check)
+ ((waived) waived)
+ ((stuck/dead) stuck)
+ (else unknown-error-5)))
+ ((fail)
+ (case nstate
+ ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail)
+ ((abort) abort)
+ (else unknown-error-6)))
+ (else unknown-error-7)))
+ (cons
+ (if nstate (symbol->string nstate) nstate)
+ (if nstatus (symbol->string nstatus) nstatus))))
+
;;======================================================================
;; D E B U G G I N G S T U F F
;;======================================================================
(define *verbosity* 1)
@@ -392,25 +495,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")
- (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")
- ))
-
-(define (common:legacy-sync-required)
- (configf:lookup *configdat* "setup" "megatest-db"))
+(define (common:run-sync?)
+ (let ((ohh (common:on-homehost?))
+ (srv (args:get-arg "-server")))
+ (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv)
+ (and (common:on-homehost?)
+ (args:get-arg "-server"))))
+
+;;;; run-ids
+;; if #f use *db-local-sync* : or 'local-sync-flags
+;; if #t use timestamps : or 'timestamps
+(define (common:sync-to-megatest.db dbstruct)
+ (let ((start-time (current-seconds))
+ (res (db:multi-db-sync dbstruct 'new2old)))
+ (let ((sync-time (- (current-seconds) start-time)))
+ (debug:print-info 3 *default-log-port* "Sync of newdb to olddb 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 completed in " sync-time " seconds")))
+ res))
+
+;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
+;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
+;;
+(define (common:watchdog)
+ (thread-sleep! 0.05) ;; delay for startup
+ (let ((legacy-sync (common:run-sync?))
+ (debug-mode (debug:debug-mode 1))
+ (last-time (current-seconds)))
+ (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync)
+ (if legacy-sync
+ (let ((dbstruct (db:setup)))
+ (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
+ (let loop ()
+ ;; sync for filesystem local db writes
+ ;;
+ (mutex-lock! *db-multi-sync-mutex*)
+ (let* ((need-sync (>= *db-last-write* *db-last-sync*)) ;; no sync since last write
+ (sync-in-progress *db-sync-in-progress*)
+ (should-sync (> (- (current-seconds) *db-last-sync*) 5)) ;; sync every five seconds minimum
+ (will-sync (and (or need-sync should-sync)
+ (not sync-in-progress)))
+ (start-time (current-seconds)))
+ ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
+ (if will-sync (set! *db-sync-in-progress* #t))
+ (mutex-unlock! *db-multi-sync-mutex*)
+ (if will-sync
+ (let ((res (common:sync-to-megatest.db dbstruct))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
+ (if (> res 0) ;; some records were transferred, keep the db alive
+ (begin
+ (mutex-lock! *heartbeat-mutex*)
+ (set! *db-last-access* (current-seconds))
+ (mutex-unlock! *heartbeat-mutex*)
+ (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
+ (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))))
+ (if will-sync
+ (begin
+ (mutex-lock! *db-multi-sync-mutex*)
+ (set! *db-sync-in-progress* #f)
+ (set! *db-last-sync* start-time)
+ (mutex-unlock! *db-multi-sync-mutex*)))
+ (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
@@ -418,23 +600,11 @@
#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))))
- (if *dbstruct-db* (db:close-all *dbstruct-db*))
- (if *inmemdb* (db:close-all *inmemdb*))
- (if (and *megatest-db*
- (sqlite3:database? *megatest-db*))
- (begin
- (sqlite3:interrupt! *megatest-db*)
- (sqlite3:finalize! *megatest-db* #t)
- (set! *megatest-db* #f)))
+ (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
(if *task-db*
(let ((db (cdr *task-db*)))
(if (sqlite3:database? db)
(begin
(sqlite3:interrupt! db)
@@ -549,10 +719,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 +804,58 @@
(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)
+;; IF *toppath* is not set, wait up to five seconds trying every two seconds
+;; (this is to accomodate the watchdog)
+;;
+(define (common:get-homehost #!key (trynum 5))
+ ;; called often especially at start up. use mutex to eliminate collisions
+ (mutex-lock! *homehost-mutex*)
+ (cond
+ (*home-host*
+ (mutex-unlock! *homehost-mutex*)
+ *home-host*)
+ ((not *toppath*)
+ (mutex-unlock! *homehost-mutex*)
+ (launch:setup) ;; safely mutexed now
+ (if (> trynum 0)
+ (begin
+ (thread-sleep! 2)
+ (common:get-homehost trynum: (- trynum 1)))
+ #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))
+ (mutex-unlock! *homehost-mutex*)
+ *home-host*))))
+
+;; am I on the homehost?
+;;
+(define (common:on-homehost?)
+ (let ((hh (common:get-homehost)))
+ (if hh
+ (cdr hh)
+ #f)))
;;======================================================================
;; M I S C L I S T S
;;======================================================================
@@ -636,10 +875,11 @@
(if (null? tala) ;; we are done
talb
(loop (car tala)
(cdr tala)
(car talb)
+
(cdr talb)))
#f)))))
;; Needed for long lists to be sorted where (apply max ... ) dies
;;
@@ -923,30 +1163,36 @@
(if (number? newval)
(set! freespc newval))))))
(car df-results))
freespc))
-;; check space in dbdir
-;; returns: ok/not dbspace required-space
-;;
-(define (common:check-db-dir-space)
- (let* ((dbdir (db:get-dbdir))
- (dbspace (if (directory? dbdir)
- (get-df dbdir)
- 0))
- (required (string->number
- (or (configf:lookup *configdat* "setup" "dbdir-space-required")
- "100000"))))
+(define (common:check-space-in-dir dirpath required)
+ (let* ((dbspace (if (directory? dirpath)
+ (get-df dirpath)
+ 0)))
(list (> dbspace required)
dbspace
required
- dbdir)))
+ dirpath)))
+;; check space in dbdir and in megatest dir
+;; returns: ok/not dbspace required-space
+;;
+(define (common:check-db-dir-space)
+ (let* ((required (string->number
+ (or (configf:lookup *configdat* "setup" "dbdir-space-required")
+ "100000")))
+ (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
+ (tdbspace (common:check-space-in-dir dbdir required))
+ (mdbspace (common:check-space-in-dir *toppath* required)))
+ (sort (list tdbspace mdbspace) (lambda (a b)
+ (< (cadr a)(cadr b))))))
+
;; check available space in dbdir, exit if insufficient
;;
(define (common:check-db-dir-and-exit-if-insufficient)
- (let* ((spacedat (common:check-db-dir-space))
+ (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now
(is-ok (car spacedat))
(dbspace (cadr spacedat))
(required (caddr spacedat))
(dbdir (cadddr spacedat)))
(if (not is-ok)
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -17,12 +17,12 @@
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
+(use srfi-1 posix regex regex-case srfi-69)
+(use (prefix sqlite3 sqlite3:))
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
@@ -158,11 +158,11 @@
;;======================================================================
;; Run info panel
;;======================================================================
(define (run-info-panel db keydat testdat runname)
(let* ((run-id (db:test-get-run_id testdat))
- (rundat (db:get-run-info db run-id))
+ (rundat (rmt:get-run-info run-id))
(header (db:get-header rundat))
(event_time (db:get-value-by-header (db:get-rows rundat)
(db:get-header rundat)
"event_time")))
(iup:frame
@@ -286,11 +286,12 @@
(iup:label "STATE:" #:size "30x")
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
- (rmt:test-set-state-status-by-id run-id test-id state #f #f)
+ ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f)
+ (rmt:roll-up-pass-fail-counts run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected
(db:test-set-state! testdat state)))))
btn))
(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
@@ -319,11 +320,12 @@
(iup:attribute-set! wtxtbox "VALUE" c)
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
- (rmt:test-set-state-status-by-id run-id test-id #f status #f)
+ ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f)
+ (rmt:roll-up-pass-fail-counts run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected
(db:test-set-status! testdat status))))))))
btn))
(map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
@@ -415,13 +417,13 @@
;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
- (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
- (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree")
- local: #t))
+ (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
+ (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree")
+ ;; local: #t))
(testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
(if (not testdat)
@@ -513,11 +515,11 @@
;; NOTE: BUG HIDER, try to eliminate this exception handler
(handle-exceptions
exn
(debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn))
(rmt:get-test-info-by-id run-id test-id )))))
- ;; (debug:print-info 0 *default-log-port* "need-update= " need-update " curr-mod-time = " curr-mod-time)
+ ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time)
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
(set! teststeps (tests:get-compressed-steps run-id test-id))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -53,10 +53,11 @@
Usage: dashboard [options]
-h : this help
-test run-id,test-id : control test identified by testid
-skip-version-check : skip the version check
+ -use-db-cache : access database via cache
Misc
-rows R : set number of rows
-cols C : set number of columns
"))
@@ -81,12 +82,13 @@
"-use-server"
"-guimonitor"
"-main"
"-v"
"-q"
- "-use-local"
+ "-use-db-cache"
"-skip-version-check"
+ "-repl"
)
args:arg-hash
0))
(if (not (null? remargs))
@@ -104,10 +106,19 @@
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
+;; create a watch dog to move changes from lt/.db/*.db to megatest.db
+;;
+(if (file-write-access? (conc *toppath* "/megatest.db"))
+ (thread-start! (make-thread common:watchdog "Watchdog thread"))
+ (if (not (args:get-arg "-use-db-cache"))
+ (begin
+ (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
+ (hash-table-set! args:arg-hash "-use-db-cache" #t))))
+
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
((curr-tab-num 0) : number)
please-update
@@ -116,11 +127,10 @@
updaters
updating
uidat ;; needs to move to tabdat at some time
hide-not-hide-tabs
)
-
(define (dboard:commondat-make)
(make-dboard:commondat
curr-tab-num: 0
tabdats: (make-hash-table)
@@ -248,10 +258,11 @@
((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
(target #f)
(test-patts #f)
;; db info to file the .db files for the area
+ (access-mode (db:get-access-mode)) ;; use cached db or not
(dbdir #f)
(dbfpath #f)
(dbkeys #f)
((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
(monitor-db-path #f) ;; where to find monitor.db
@@ -261,11 +272,11 @@
((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
;; runs tree
((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
(runs-tree #f)
- ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targests added to tree (merge functionality with path-run-ids?)
+ ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
;; tab data
((view-changed #t) : boolean)
((xadj 0) : number) ;; x slider number (if using canvas)
((yadj 0) : number) ;; y slider number (if using canvas)
@@ -297,18 +308,18 @@
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
- (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
- (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
+ (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+ (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
- (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
+ (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
)
;; RADT => Matrix defstruct addition
@@ -479,21 +490,22 @@
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
- (let* ((num-to-get
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (num-to-get
(let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get")))
(if num-tests-from-config
(begin
(BB> "override num-tests 100 -> "num-tests-from-config)
(string->number num-tests-from-config))
100)))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
- (do-not-use-db-file-timestamps (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
- (do-not-use-query-timestamps (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
+ (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
+ (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
@@ -516,29 +528,30 @@
(db-pth (conc db-dir "/" run-id ".db")))
(dboard:rundat-db-path-set! run-dat db-pth)
db-pth)))
(tmptests (if (or do-not-use-db-file-timestamps
(>= (common:lazy-modification-time db-path) last-update))
- (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
- (dboard:rundat-run-data-offset run-dat)
- num-to-get
- (dboard:tabdat-hide-not-hide tabdat) ;; no-in
- sort-by ;; sort-by
- sort-order ;; sort-order
- #f ;; 'shortlist ;; qrytype
- (if (dboard:tabdat-filters-changed tabdat)
- 0
- last-update) ;; last-update
- *dashboard-mode*) ;; use dashboard mode
+ (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
+ run-id testnamepatt states statuses ;; run-id testpatt states statuses
+ (dboard:rundat-run-data-offset run-dat)
+ num-to-get
+ (dboard:tabdat-hide-not-hide tabdat) ;; no-in
+ sort-by ;; sort-by
+ sort-order ;; sort-order
+ #f ;; 'shortlist ;; qrytype
+ (if (dboard:tabdat-filters-changed tabdat)
+ 0
+ last-update) ;; last-update
+ *dashboard-mode*) ;; use dashboard mode
'()))
(use-new (dboard:tabdat-hide-not-hide tabdat))
(tests-ht (if (dboard:tabdat-filters-changed tabdat)
(let ((ht (make-hash-table)))
(dboard:rundat-tests-set! run-dat ht)
ht)
- (dboard:rundat-tests run-dat)))
- (start-time (current-seconds)))
+ (dboard:rundat-tests run-dat))))
+ ;;(start-time (current-seconds)))
;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
(dboard:rundat-run-data-offset-set!
run-dat
(if (< (length tmptests) num-to-get)
@@ -592,15 +605,18 @@
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
- (let* ((keys (rmt:get-keys))
- (last-runs-update (dboard:tabdat-last-runs-update tabdat))
- (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (keys (db:dispatch-query access-mode rmt:get-keys db:get-keys))
+ (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
+ (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs
+ runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
- (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update));;'("id" "runname")
+ (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
+ keys "%" #f #f #f #f last-runs-update));;'("id" "runname")
(header (db:get-header allruns))
(runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
(runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
(start-time (current-seconds))
(runs-hash (let ((ht (make-hash-table)))
@@ -662,12 +678,88 @@
(loop run tal new-res newmaxtests) ;; not done getting data for this run
(loop (car tal)(cdr tal) new-res newmaxtests)))))))
(dboard:tabdat-filters-changed-set! tabdat #f)
(dboard:update-tree tabdat runs-hash header tb)))
-
-
+;; this calls dboard:get-tests-for-run-duplicate for each run
+;;
+;; create a virtual table of all the tests
+;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
+;;
+(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys)))
+ (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
+ (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs
+ runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
+ ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
+ keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
+ (header (db:get-header allruns))
+ (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
+ (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
+ (start-time (current-seconds))
+ (runs-hash (let ((ht (make-hash-table)))
+ (for-each (lambda (run)
+ (hash-table-set! ht (db:get-value-by-header run header "id") run))
+ runs-tree) ;; (vector-ref runs-dat 1))
+ ht))
+ (tb (dboard:tabdat-runs-tree tabdat)))
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (dboard:tabdat-header-set! tabdat header)
+ ;;
+ ;; trim runs to only those that are changing often here
+ ;;
+ (if (null? runs)
+ (begin
+ (dboard:tabdat-allruns-set! tabdat '())
+ (dboard:tabdat-all-test-names-set! tabdat '())
+ (dboard:tabdat-item-test-names-set! tabdat '())
+ (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
+ (let loop ((run (car runs))
+ (tal (cdr runs))
+ (res '())
+ (maxtests 0))
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
+ ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
+ (key-vals (rmt:get-key-vals run-id))
+ (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
+ ;; dboard:get-tests-for-run-duplicate - returns a hash table
+ ;; (dboard:get-tests-dat tabdat run-id last-update))
+ (all-test-ids (hash-table-keys tests-ht))
+ (num-tests (length all-test-ids)))
+ ;; (print "run-struct: " run-struct)
+ ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
+ ;; (tests (bubble-up tmptests priority: bubble-type))
+ ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
+ ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
+ ;; Not sure this is needed?
+ (let* ((newmaxtests (max num-tests maxtests))
+ ;; (last-update (- (current-seconds) 10))
+ (run-struct (or run-struct
+ (dboard:rundat-make-init
+ run: run
+ tests: tests-ht
+ key-vals: key-vals)))
+ (new-res (if (null? all-test-ids) res (cons run-struct res)))
+ (elapsed-time (- (current-seconds) start-time)))
+ (if (null? all-test-ids)
+ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
+ (if (or (null? tal)
+ (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
+ (begin
+ (if (> elapsed-time 2)(print "NOTE: updates are taking a long time, " elapsed-time "s elapsed."))
+ (dboard:tabdat-allruns-set! tabdat new-res)
+ maxtests)
+ (if (> (dboard:rundat-run-data-offset run-struct) 0)
+ (loop run tal new-res newmaxtests) ;; not done getting data for this run
+ (loop (car tal)(cdr tal) new-res newmaxtests)))))))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (dboard:update-tree tabdat runs-hash header tb)))
(define *collapsed* (make-hash-table))
(define (toggle-hide lnum uidat) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
@@ -1476,11 +1568,13 @@
(if (not (null? path))
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
(define (dboard:get-tests-dat tabdat run-id last-update)
- (let* ((tdat (if run-id (rmt:get-tests-for-run run-id
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
+ run-id
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
(hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
(hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
#f #f ;; offset limit
(dboard:tabdat-hide-not-hide tabdat) ;; not-in
@@ -1507,20 +1601,22 @@
(if (and res (> (length res) 1))
(cadr res)
#f)))
(define (dboard:update-tree tabdat runs-hash runs-header tb)
- (let* ((run-ids (sort (filter number? (hash-table-keys runs-hash))
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a runs-header "event_time"))
(time-b (db:get-value-by-header record-b runs-header "event_time")))
(< time-a time-b)))))
(changed #f)
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
+ (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
+ (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
(dboard:tabdat-keys tabdat)))
@@ -1585,12 +1681,14 @@
hide-clean: hide-clean)
#f)))
(define (dashboard:get-runs-hash tabdat)
- (let* ((last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
+ (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
@@ -1598,15 +1696,17 @@
runs) ht)))
runs-hash))
(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
- (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
- (dashboard:do-update-rundat tabdat))
+ ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
+ (dashboard:do-update-rundat tabdat) ;; )
(dboard:runs-summary-control-panel-updater tabdat)
(let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (runs-dat (db:dispatch-query (dboard:tabdat-access-mode tabdat)
+ rmt:get-runs-by-patt db:get-runs-by-patt
+ (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(runs-hash (dashboard:get-runs-hash tabdat))
;; (runs-hash (let ((ht (make-hash-table)))
@@ -2034,11 +2134,10 @@
(mark-for-update tabdat)
(update-search commondat tabdat "test-name" val))
"make-controls")))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)
- ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat)))
(exit))
#:expand "NO" #:size "40x15")
(iup:button "Refresh" #:action (lambda (obj)
(mark-for-update tabdat))
#:expand "NO" #:size "40x15")
@@ -2567,29 +2666,29 @@
(define *last-recalc-ended-time* 0)
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
- (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
- (> modtime last-db-update-time)
+ (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
+ (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
(> (current-seconds)(+ last-db-update-time 1)))))
;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(tasks:open-db)
-(define (dashboard:get-youngest-run-db-mod-time tabdat)
+(define (dashboard:get-youngest-run-db-mod-time dbdir)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(common:max (map (lambda (filen)
- (file-modification-time filen))
- (glob (conc (dboard:tabdat-dbdir tabdat) "/*.db"))))))
+ (file-modification-time filen))
+ (glob (conc dbdir "/*.db*"))))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
@@ -2607,19 +2706,23 @@
(hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))
(define (dboard:set-last-db-update! tabdat context newtime)
(hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
+;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db
+;; is closed (I think). If db dir starts with /tmp always return true
+;;
(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
(let* ((run-update-time (current-seconds))
- (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!!
+ (dbdir (dboard:tabdat-dbdir tabdat))
+ (modtime (dashboard:get-youngest-run-db-mod-time dbdir))
(recalc (dashboard:recalc modtime
(dboard:commondat-please-update commondat)
- (dboard:get-last-db-update tabdat context-key))))
- ;; (dboard:tabdat-last-db-update tabdat))))
+ (dboard:get-last-db-update tabdat context-key))))
+ ;; (dboard:tabdat-last-db-update tabdat))))
(if recalc
- (dboard:set-last-db-update! tabdat context-key run-update-time))
+ (dboard:set-last-db-update! tabdat context-key run-update-time))
(dboard:commondat-please-update-set! commondat #f)
recalc))
;; point inside line
;;
@@ -2713,12 +2816,15 @@
(db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
- (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (db:dispatch-query access-mode
+ rmt:get-runs-by-patt db:get-runs-by-patt
+ (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
(vector-ref runs-dat 1))
@@ -3256,15 +3362,16 @@
;; (define (tabdat-values tabdat)
;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat tabdat)
- (update-rundat
+ (dboard:update-rundat
tabdat
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
+ ;; generate key patterns from the target stored in tabdat
(let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
(let ((fres (if (dboard:tabdat-target tabdat)
(let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
(map (lambda (k v)(list k v)) dbkeys ptparts))
(let ((res '()))
@@ -3282,13 +3389,14 @@
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
;;(tabdat-values tabdat) ;;RA added
;; (pp (dboard:tabdat->alist tabdat))
+ ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)
(dashboard:do-update-rundat tabdat)
(let ((uidat (dboard:commondat-uidat commondat)))
- ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
+ ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
;;======================================================================
@@ -3319,11 +3427,11 @@
(debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
;; ((args:get-arg "-guimonitor")
;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
(else
- (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
+ (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat))
(dboard:commondat-curr-tab-num-set! commondat 0)
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
@@ -3357,7 +3465,9 @@
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
-(main)
+(if (args:get-arg "-repl")
+ (repl)
+ (main))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -38,24 +38,15 @@
;;======================================================================
;; R E C O R D S
;;======================================================================
+;; each db entry is a pair ( db . dbfilepath )
(defstruct dbr:dbstruct
- main
- strdb
- ((path #f) : string)
- ((local #f) : boolean)
- rundb
- inmem
- mtime
- rtime
- stime
- inuse
- refdb
- ((locdbs (make-hash-table)) : hash-table)
- olddb)
+ (tmpdb #f)
+ (mtdb #f)
+ (refndb #f))
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
@@ -86,22 +77,15 @@
;; if #f => get main db
;; if db already open - return inmem
;; if db not open, open inmem, rundb and sync then return inmem
;; inuse gets set automatically for rundb's
;;
-(define (db:get-db dbstruct run-id)
- (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
- dbstruct
- (begin
- (let ((dbdat (if (or (not run-id)
- (eq? run-id 0))
- (db:open-main dbstruct)
- (db:open-rundb dbstruct run-id)
- )))
- dbdat))))
-
-;; legacy handling of structure for managing db's. Refactor this into dbr:?
+(define (db:get-db dbstruct . blah) ;; run-id)
+ (or (dbr:dbstruct-tmpdb dbstruct)
+ (db:open-db dbstruct)))
+
+;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
dbdat))
@@ -113,35 +97,38 @@
;; mod-read:
;; 'mod modified data
;; 'read read data
;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct
;;
-(define (db:done-with dbstruct run-id mod-read)
- (if (not (sqlite3:database? dbstruct))
- (begin
- (mutex-lock! *rundb-mutex*)
- (if (eq? mod-read 'mod)
- (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
- (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
- (dbr:dbstruct-inuse-set! dbstruct #f)
- (mutex-unlock! *rundb-mutex*))))
-
-;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
+;; (define (db:done-with dbstruct run-id mod-read)
+;; (if (not (sqlite3:database? dbstruct))
+;; (begin
+;; (mutex-lock! *rundb-mutex*)
+;; (if (eq? mod-read 'mod)
+;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
+;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
+;; (dbr:dbstruct-inuse-set! dbstruct #f)
+;; (mutex-unlock! *rundb-mutex*))))
+
+;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
(let* ((dbdat (if (dbr:dbstruct? dbstruct)
(db:get-db dbstruct run-id)
- dbstruct)) ;; cheat, allow for passing in a dbdat
+ (begin
+ (print-call-chain)
+ (print "db:with-db called with dbdat instead of dbstruct, FIXME!!")
+ dbstruct))) ;; cheat, allow for passing in a dbdat
(db (db:dbdat-get-db dbdat)))
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let ((res (apply proc db params)))
- (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
+ ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
res))))
;;======================================================================
;; K E E P F I L E D B I N dbstruct
;;======================================================================
@@ -169,30 +156,30 @@
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
-(define (db:dbfile-path run-id)
- (let* ((dbdir (db:get-dbdir))
- (fname (if run-id
- (if (eq? run-id 0) "main.db" (conc run-id ".db"))
- #f)))
+(define (db:dbfile-path . junk) ;; run-id)
+ (let* ((dbdir (common:get-db-tmp-area))) ;; (db:get-dbdir))
+;; (fname (if run-id
+;; (if (eq? run-id 0) "main.db" (conc run-id ".db"))
+;; #f)))
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(if (not (directory? dbdir))(create-directory dbdir #t)))
- (if fname
- (conc dbdir "/" fname)
- dbdir)))
+ dbdir)) ;; (if fname
+;; (conc dbdir "/" fname)
+;; dbdir)))
;; Returns the database location as specified in config file
;;
-(define (db:get-dbdir)
- (or (configf:lookup *configdat* "setup" "dbdir")
- (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
+;; (define db:get-dbdir common:get-db-tmp-area)
+;; (or (configf:lookup *configdat* "setup" "dbdir")
+;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))
@@ -199,26 +186,22 @@
;; 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 )))
(if file-write ;; dir-writable
(let (;; (lock (obtain-dot-lock fname 1 5 10))
(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:set-sync db)
+ (sqlite3:execute db "PRAGMA synchronous = NORMAL;")
(if (not file-exists)
(begin
(if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp
(sqlite3:execute db "PRAGMA journal_mode=WAL;")
(print "Creating " fname " in NON-WAL mode."))
@@ -227,122 +210,92 @@
db)
(begin
(debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
(sqlite3:open-database fname))))) ;; )
-;; This routine creates the db. It is only called if the db is not already opened
-;;
-(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
- (let* ((local (dbr:dbstruct-local dbstruct))
- (rdb (if local
- (dbr:dbstruct-localdb dbstruct run-id)
- (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-runrec dbstruct run-id 'inmem)))
- (if (or rdb
- do-not-open)
- rdb
- (begin
- (mutex-lock! *rundb-mutex*)
- (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
- (dbexists (file-exists? dbpath))
- (inmem (if local #f (db:open-inmem-db)))
- (refdb (if local #f (db:open-inmem-db)))
- (db (db:lock-create-open dbpath ;; this is the database physically on disk
- (lambda (db)
- (handle-exceptions
- exn
- (begin
- ;; (release-dot-lock dbpath)
- (if (> attemptnum 2)
- (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
- (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1))))
- (db:initialize-run-id-db db)
- (sqlite3:execute
- db
- "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
- (* run-id 30000) ;; allow for up to 30k tests per run
- run-id)
- ;; do a dummy query to test that the table exists and the db is truly readable
- (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000))
- )))) ;; add strings db to rundb, not in use yet
- ;; )) ;; (sqlite3:open-database dbpath))
- (olddb (if *megatest-db*
- *megatest-db*
- (let ((db (db:open-megatest-db)))
- (set! *megatest-db* db)
- db)))
- (write-access (file-write-access? dbpath))
- ;; (handler (make-busy-timeout 136000))
- )
- (if (and dbexists (not write-access))
- (set! *db-write-access* #f)) ;; only unset so other db's also can use this control
- (dbr:dbstruct-rundb-set! dbstruct (cons db dbpath))
- (dbr:dbstruct-inuse-set! dbstruct #t)
- (dbr:dbstruct-olddb-set! dbstruct olddb)
- ;; (dbr:dbstruct-run-id-set! dbstruct run-id)
- (mutex-unlock! *rundb-mutex*)
- (if local
- (begin
- (dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-inmem-set! dbstruct db) ;; direct access ...
- db)
- (begin
- (dbr:dbstruct-inmem-set! dbstruct inmem)
- ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
- ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
- (db:sync-tables db:sync-tests-only db inmem)
- (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve?
- (dbr:dbstruct-refdb-set! dbstruct refdb)
- (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
- ;; sync once more to deal with delays?
- ;; (db:sync-tables db:sync-tests-only db inmem)
- ;; (db:sync-tables db:sync-tests-only inmem refdb)
- inmem)))))))
-
-;; This routine creates the db if not already present. It is only called if the db is not already ls opened
-;;
-(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
- (let ((mdb (dbr:dbstruct-main dbstruct))) ;; RA => Returns the first reference in dbstruct
- (if mdb
- mdb
- (begin
- (mutex-lock! *rundb-mutex*)
- (let* ((dbpath (db:dbfile-path 0))
- (dbexists (file-exists? dbpath))
- (db (db:lock-create-open dbpath db:initialize-main-db))
- (olddb (db:open-megatest-db))
- (write-access (file-write-access? dbpath))
- (dbdat (cons db dbpath)))
- (if (and dbexists (not write-access))
- (set! *db-write-access* #f))
- (dbr:dbstruct-main-set! dbstruct dbdat)
- (dbr:dbstruct-olddb-set! dbstruct olddb) ;; olddb is already a (cons db path)
- (mutex-unlock! *rundb-mutex*)
- (if (and (not dbexists)
- *db-write-access*) ;; did not have a prior db and do have write access
- (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically
- dbdat)))))
+;; ;; This routine creates the db. It is only called if the db is not already opened
+;; ;;
+;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
+;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
+;; (dbexists (file-exists? dbfile))
+;; (db (db:lock-create-open dbfile (lambda (db)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; ;; (release-dot-lock dbpath)
+;; (if (> attemptnum 2)
+;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
+;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1))))
+;; (db:initialize-run-id-db db)
+;; (sqlite3:execute
+;; db
+;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
+;; (* run-id 30000) ;; allow for up to 30k tests per run
+;; run-id)
+;; ;; do a dummy query to test that the table exists and the db is truly readable
+;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000))
+;; )))) ;; add strings db to rundb, not in use yet
+;; (olddb (if *megatest-db*
+;; *megatest-db*
+;; (let ((db (db:open-megatest-db)))
+;; (set! *megatest-db* db)
+;; db)))
+;; (write-access (file-write-access? dbfile)))
+;; (if (and dbexists (not write-access))
+;; (set! *db-write-access* #f)) ;; only unset so other db's also can use this control
+;; (dbr:dbstruct-rundb-set! dbstruct (cons db dbfile))
+;; (dbr:dbstruct-inuse-set! dbstruct #t)
+;; (dbr:dbstruct-olddb-set! dbstruct olddb)
+;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's?
+;; (db:sync-tables db:sync-tests-only *megatest-db* db)
+;; db))
+
+;; This routine creates the db if not already present. It is only called if the db is not already opened
+;;
+(define (db:open-db dbstruct #!key (areapath #f))
+ (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct
+ (if tmpdb
+ tmpdb
+ ;; (mutex-lock! *rundb-mutex*)
+ (let* ((dbpath (db:dbfile-path)) ;; 0))
+ (dbexists (file-exists? dbpath))
+ (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
+ (mtdb (db:open-megatest-db))
+ (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
+ (write-access (file-write-access? dbpath)))
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f))
+ (dbr:dbstruct-mtdb-set! dbstruct mtdb)
+ (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) ;; olddb is already a (cons db path)
+ (dbr:dbstruct-refndb-set! dbstruct refndb)
+ ;; (mutex-unlock! *rundb-mutex*)
+ (if (and (not dbexists)
+ *db-write-access*) ;; did not have a prior db and do have write access
+ (db:multi-db-sync dbstruct '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)))
- dbstruct))
-
-;; open the local db for direct access (no server)
-;;
-(define (db:open-local-db-handle)
+(define (db:setup #!key (areapath #f))
(or *dbstruct-db*
- (let ((dbstruct (db:setup #f local: #t)))
- (set! *dbstruct-db* dbstruct)
- dbstruct)))
-
-;; Open the classic megatest.db file in toppath
+ (if (common:on-homehost?)
+ (let* ((dbstruct (make-dbr:dbstruct)))
+ (db:open-db dbstruct areapath: #f)
+ (set! *dbstruct-db* dbstruct)
+ dbstruct)
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting.")
+ (exit 1)))))
+
+;; Open the classic megatest.db file (defaults to open in toppath)
;;
-(define (db:open-megatest-db)
- (let* ((dbpath (conc *toppath* "/megatest.db"))
+;; NOTE: returns a dbdat not a dbstruct!
+;;
+(define (db:open-megatest-db #!key (path #f)(name #f))
+ (let* ((dbpath (conc (or path *toppath*) "/" (or name "megatest.db")))
(dbexists (file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db)
(db:initialize-run-id-db db))))
@@ -352,94 +305,47 @@
(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))
- ;; (runid (dbr:dbstruct-run-id dbstruct))
- )
+ (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))
+ (mtdb (dbr:dbstruct-mtdb dbstruct))
+ (refndb (dbr:dbstruct-refndb dbstruct))
+ (start-t (current-seconds)))
(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)))))
+ (mutex-lock! *db-multi-sync-mutex*)
+ (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
+ (mutex-unlock! *db-multi-sync-mutex*)
+ (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
+ (mutex-lock! *db-multi-sync-mutex*)
+ (set! *db-last-sync* start-t)
+ (mutex-unlock! *db-multi-sync-mutex*)))
;; 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) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
+ (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct)))
+ (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
+ (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))))
+ (if tdb (sqlite3:finalize! tdb))
+ (if mdb (sqlite3:finalize! mdb))
+ (if rdb (sqlite3:finalize! rdb))))))
+
+;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
+;; (if (hash-table? locdbs)
+;; (for-each (lambda (run-id)
+;; (db:close-run-db dbstruct run-id))
+;; (hash-table-keys locdbs)))))
+
+;; (define (db:open-inmem-db)
+;; (let* ((db (sqlite3:open-database ":memory:"))
+;; (handler (make-busy-timeout 3600)))
+;; (sqlite3:set-busy-handler! db handler)
+;; (db:initialize-run-id-db db)
+;; (cons db #f)))
;; just tests, test_steps and test_data tables
(define db:sync-tests-only
(list
;; (list "strs"
@@ -489,12 +395,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 +419,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,16 +501,18 @@
#t))))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
-(define (db:sync-tables tbls fromdb todb . slave-dbs)
- (mutex-lock! *db-sync-mutex*)
+;; 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)
(handle-exceptions
exn
(begin
- (mutex-unlock! *db-sync-mutex*)
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
@@ -613,19 +525,11 @@
(debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
(exit)))))
(cons todb slave-dbs))
0)
-;; (if *server-run* ;; we are inside a server, throw a sync-failed error
-;; (signal (make-composite-condition
-;; (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context.")))
-;; 0)) ;; return zero for num synced
-
- ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die.
- ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
- ;; (portlogger:open-run-close portlogger:set-port port "released")
- ;; (exit 1)))
+ ;; this is the work to be done
(cond
((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1)
((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2)
((not (sqlite3:database? (db:dbdat-get-db fromdb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3)
@@ -639,15 +543,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,25 +635,24 @@
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)))
(set! tot-count (+ tot-count count))
(if (> count 0)
(if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
(sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
- tot-count)))
- (mutex-unlock! *db-sync-mutex*)))
+ tot-count)))))
-
-(define (db:patch-schema-rundb run-id frundb)
+(define (db:patch-schema-rundb frundb)
;;
;; remove this some time after September 2016 (added in version v1.6031
;;
(for-each
(lambda (table-name)
@@ -762,19 +676,19 @@
WHERE id=old.id;
END;"))
)
'("tests" "test_steps" "test_data")))
-(define (db:patch-schema-maindb run-id maindb)
+(define (db:patch-schema-maindb maindb)
;;
;; remove all these some time after september 2016 (added in v1.6031
;;
(handle-exceptions
exn
(if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "Column last_update already added to runs table")
- (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none"))
+ (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
(sqlite3:execute
maindb
"ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0"))
;; these schema changes don't need exception handling
(sqlite3:execute
@@ -796,147 +710,232 @@
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)
- ))
+(define (db:multi-db-sync dbstruct . options)
+ (if (not (launch:setup))
+ (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
+ (let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
+ (tmpdb (dbr:dbstruct-tmpdb dbstruct))
+ (refndb (dbr:dbstruct-refndb dbstruct))
+ (allow-cleanup #t) ;; (if run-ids #f #t))
+ (tdbdat (tasks:open-db))
+ (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
+ (data-synced 0)) ;; count of changed records (I hope)
+
+ ;; kill servers
+ (if (member 'killservers options)
+ (for-each
+ (lambda (server)
+ (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration")
+ (tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
+ servers))
+
+ ;; clear out junk records
+ ;;
+ (if (member 'dejunk options)
+ (begin
+ (db:delay-if-busy mtdb) ;; ok to delay on mtdb
+ (db:clean-up mtdb)
+ (db:clean-up tmpdb)
+ (db:clean-up refndb)))
+
+ ;; adjust test-ids to fit into proper range
+ ;;
+ ;; (if (member 'adj-testids options)
+ ;; (begin
+ ;; (db:delay-if-busy mtdb)
+ ;; (db:prep-megatest.db-for-migration mtdb)))
+
+ ;; sync runs, test_meta etc.
+ ;;
+ (if (member 'old2new options)
+ ;; (begin
+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb))
+ ;; (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
+;; (for-each
+;; (lambda (run-id)
+;; (db:delay-if-busy mtdb)
+;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
+;; ;; (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
+;; (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
+;; (db:replace-test-records dbstruct run-id testrecs)
+;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct)))))
+;; run-ids)))
+
+ ;; now ensure all newdb data are synced to megatest.db
+ ;; do not use the run-ids list passed in to the function
+ ;;
+ (if (member 'new2old options)
+ (set! data-synced
+ (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
+ data-synced)))
+
+
+ (if (member 'fixschema options)
+ (begin
+ (db:patch-schema-maindb (db:dbdat-get-db mtdb))
+ (db:patch-schema-maindb (db:dbdat-get-db tmpdb))
+ (db:patch-schema-maindb (db:dbdat-get-db refndb))
+ (db:patch-schema-rundb (db:dbdat-get-db mtdb))
+ (db:patch-schema-rundb (db:dbdat-get-db tmpdb))
+ (db:patch-schema-rundb (db:dbdat-get-db refndb))))
+
+ ;; (let* ((maindb (make-dbr:dbstruct path: toppath local: #t))
+ ;; (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0)))))
+ ;; (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <))
+ ;; (count 1)
+ ;; (total (length all-run-ids))
+ ;; (dead-runs '()))
+ ;; ;; first fix schema if needed
+ ;; (map
+ ;; (lambda (th)
+ ;; (thread-join! th))
+ ;; (map
+ ;; (lambda (run-id)
+ ;; (thread-start!
+ ;; (make-thread
+ ;; (lambda ()
+ ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
+;; (if (member 'schema options)
+ ;; (if (eq? run-id 0)
+ ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
+ ;; (db:patch-schema-maindb run-id maindb))
+ ;; (db:patch-schema-rundb run-id frundb)))
+ ;; (set! count (+ count 1))
+ ;; (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
+ ;; all-run-ids))
+ ;; ;; Then sync and fix db's
+ ;; (set! count 0)
+ ;; (process-fork
+ ;; (lambda ()
+ ;; (map
+ ;; (lambda (th)
+ ;; (thread-join! th))
+ ;; (map
+ ;; (lambda (run-id)
+ ;; (thread-start!
+ ;; (make-thread
+ ;; (lambda ()
+ ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
+ ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
+ ;; (if (eq? run-id 0)
+ ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
+;; (db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb)
+ ;; (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
+ ;; (begin
+ ;; ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
+;; (db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb)
+ ;; (db:clean-up-rundb (db:get-db fromdb run-id)))))
+ ;; (set! count (+ count 1))
+ ;; (debug:print 0 *default-log-port* "Finished clean up of "
+ ;; (if (eq? run-id 0)
+ ;; " main.db " (conc run-id ".db")) ", " count " of " total)))))
+ ;; all-run-ids))))
+
+ ;; removed deleted runs
+;; (let ((dbdir (tasks:get-task-db-path)))
+;; (for-each (lambda (run-id)
+;; (let ((fullname (conc dbdir "/" run-id ".db")))
+;; (if (file-exists? fullname)
+;; (begin
+;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname)
+;; (delete-file fullname)))))
+;; dead-runs))))
+;;
+ ;; (db:close-all dbstruct)
+ ;; (sqlite3:finalize! mdb)
+ data-synced)))
;; 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)
+ (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
+ (exit)
(if (or *db-write-access*
- (not (member proc *db:all-write-procs*)))
+ (not #t)) ;; was: (member proc * db:all-write-procs *)))
(let* ((db (cond
((pair? idb) (db:dbdat-get-db idb))
((sqlite3:database? idb) idb)
((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
((procedure? idb) (idb))
@@ -1314,11 +1313,11 @@
;;======================================================================
;; L O G G I N G D B
;;======================================================================
-(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
+(define (open-logging-db)
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
@@ -1370,11 +1369,11 @@
;;
;; HOWEVER: this code in run:test seems to work fine
;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; 600)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path)
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
@@ -1386,11 +1385,11 @@
"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
run-id deadtime)
;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
;;
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path)
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
@@ -1434,11 +1433,11 @@
;;
;; HOWEVER: this code in run:test seems to work fine
;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; 600)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path)
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
@@ -1450,11 +1449,11 @@
"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
run-id deadtime)
;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
;;
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path)
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
@@ -1466,11 +1465,11 @@
(debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
;;
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(let* (;; (min-incompleted (filter (lambda (x)
;; (let* ((testpath (cadr x))
;; (tdatpath (conc testpath "/testdat.db"))
;; (dbexists (file-exists? tdatpath)))
;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete
@@ -1487,18 +1486,20 @@
(string-intersperse (map conc all-ids) ",")
");")))))
;; Now do rollups for the toplevel tests
;;
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(for-each
(lambda (toptest)
(let ((test-name (list-ref toptest 3)))
;; (run-id (list-ref toptest 5)))
(db:top-test-set-per-pf-counts dbstruct run-id test-name)))
toplevels)))
+;; BUG: Probably broken - does not explicitly use run-id in the query
+;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
(db:general-call (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
;; Clean out old junk and vacuum the database
@@ -1529,11 +1530,11 @@
;; delete all runs that are state='deleted'
"DELETE FROM runs WHERE state='deleted';"
;; delete empty runs
"DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);"
))))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Records count before clean: " tot))
@@ -1543,11 +1544,11 @@
(debug:print-info 0 *default-log-port* "Records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
;; (db:find-and-mark-incomplete db)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:execute db "VACUUM;")))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
@@ -1570,11 +1571,11 @@
;; delete all tests that belong to runs that are 'deleted'
;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
;; delete all tests that are 'DELETED'
"DELETE FROM tests WHERE state='DELETED';"
))))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Records count before clean: " tot))
@@ -1584,11 +1585,11 @@
(debug:print-info 0 *default-log-port* "Records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
;; (db:find-and-mark-incomplete db)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:execute db "VACUUM;")))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
@@ -1617,11 +1618,11 @@
(sqlite3:for-each-row
(lambda (run-id)
(set! dead-runs (cons run-id dead-runs)))
db
"SELECT id FROM runs WHERE state='deleted';")
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Records count before clean: " tot))
@@ -1631,11 +1632,11 @@
(debug:print-info 0 *default-log-port* "Records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
;; (db:find-and-mark-incomplete db)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:execute db "VACUUM;")
dead-runs))
;;======================================================================
;; M E T A G E T A N D S E T V A R S
@@ -1789,23 +1790,23 @@
(key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
(debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
(debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
(if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
(let ((res #f))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
allvals)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(apply sqlite3:for-each-row
(lambda (id)
(set! res id))
db
(let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
;(debug:print 4 *default-log-port* "qry: " qry)
qry)
qryvals)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
res)
(begin
(debug:print-error 0 *default-log-port* "Called without all necessary keys")
#f))))
@@ -1854,11 +1855,11 @@
(vector header res)))
;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
;;
(define (db:get-changed-run-ids since-time)
- (let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir"))
+ (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
(alldbs (glob (conc dbdir "/[0-9]*.db")))
(changed (filter (lambda (dbfile)
(> (file-modification-time dbfile) since-time))
alldbs)))
(delete-duplicates
@@ -1993,11 +1994,11 @@
(totals (make-hash-table))
(curr (make-hash-table))
(res '())
(runs-info '()))
;; First get all the runname/run-ids
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (run-id runname)
(set! runs-info (cons (list run-id runname) runs-info)))
db
"SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
@@ -2090,11 +2091,11 @@
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ","))))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
db
(conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
@@ -2118,15 +2119,15 @@
;; First set any related tests to DELETED
(let* ((rdbdat (db:get-db dbstruct run-id))
(rdb (db:dbdat-get-db rdbdat))
(dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
- (db:delay-if-busy rdbdat)
+ ;; (db:delay-if-busy rdbdat)
(sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';")
(sqlite3:execute rdb "DELETE FROM test_steps;")
(sqlite3:execute rdb "DELETE FROM test_data;")
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))
(define (db:update-run-event_time dbstruct run-id)
(db:with-db
dbstruct
@@ -2151,11 +2152,11 @@
(debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
(define (db:set-run-status dbstruct run-id status msg)
(let* ((dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(if msg
(sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
(sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))
(define (db:get-run-status dbstruct run-id)
@@ -2185,11 +2186,11 @@
(dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons (list key key-val) res)))
db qry run-id)))
keys)
@@ -2202,11 +2203,11 @@
(dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons key-val res)))
db qry run-id)))
keys)
@@ -2411,10 +2412,11 @@
(db:general-call dbdat 'delete-test-step-records (list test-id))
;; (db:delay-if-busy)
(db:general-call dbdat 'delete-test-data-records (list test-id))
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))
+;;
(define (db:delete-old-deleted-test-records dbstruct)
(let ((run-ids (db:get-all-run-ids dbstruct))
(targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
(for-each
(lambda (run-id)
@@ -2473,11 +2475,11 @@
(if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
test-id))))
(mt:process-triggers run-id test-id newstate newstatus))))
-;; NEW BEHAVIOR: Count tests running in only one run!
+;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id)
(db:with-db
dbstruct
run-id
@@ -2537,11 +2539,11 @@
(db (db:dbdat-get-db dbdat)))
(if (not jobgroup)
0 ;;
(let ((testnames '()))
;; get the testnames
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (testname)
(set! testnames (cons testname testnames)))
db
"SELECT testname FROM test_meta WHERE jobgroup=?"
@@ -2583,13 +2585,13 @@
run-id
#f
(lambda (db)
(db:first-result-default
db
- "SELECT id FROM tests WHERE testname=? AND item_path=?;"
+ "SELECT id FROM tests WHERE testname=? AND item_path=? AND run_id=?;"
#f ;; the default
- testname item-path))))
+ testname item-path run-id))))
;; overload the unused attemptnum field for the process id of the runscript or
;; ezsteps step script in progress
;;
(define (db:test-set-top-process-pid dbstruct run-id test-id pid)
@@ -2640,11 +2642,11 @@
(let* ((dbdat (if (vector? dbstruct)
(db:get-db dbstruct run-id)
dbstruct)) ;; still settling on when to use dbstruct or dbdat
(db (db:dbdat-get-db dbdat))
(res '()))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
(set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
res)))
@@ -2746,11 +2748,11 @@
db
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
(string-intersperse (map conc test-ids) ",") ");"))
res))))
-(define (db:get-test-info dbstruct run-id testname item-path)
+(define (db:get-test-info dbstruct run-id test-name item-path)
(db:with-db
dbstruct
run-id
#f
(lambda (db)
@@ -2757,12 +2759,12 @@
(let ((res #f))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (apply vector a b)))
db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;")
- test-name item-path)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;")
+ test-name item-path run-id)
res))))
(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
(db:with-db
dbstruct
@@ -2835,11 +2837,11 @@
(define (db:test-data-rollup dbstruct run-id test-id status)
(let* ((dbdat (db:get-db dbstruct run-id))
(db (db:dbdat-get-db dbdat))
(fail-count 0)
(pass-count 0))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (fcount pcount)
(set! fail-count fcount)
(set! pass-count pcount))
db
@@ -2985,11 +2987,11 @@
((>=) (if (>= value expected) "pass" "fail"))
((<=) (if (<= value expected) "pass" "fail"))
(else (conc "ERROR: bad tol comparator " tol))))))
(debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
test-id category variable value expected tol units (if comment comment "") status type)))
csvlist)))
;; This routine moved from tdb.scm, tdb:read-test-data
@@ -2996,11 +2998,11 @@
;;
(define (db:read-test-data dbstruct run-id test-id categorypatt)
(let* ((dbdat (db:get-db dbstruct run-id))
(db (db:dbdat-get-db dbdat))
(res '()))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
db
"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
@@ -3094,48 +3096,124 @@
(begin
(debug:print-error 0 *default-log-port* "reception failed. Received " msg " but cannot translate it.")
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
+
+;; This is to be the big daddy call
(define (db:test-set-status-state dbstruct run-id test-id status state msg)
(let ((dbdat (db:get-db dbstruct run-id)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
(db:general-call dbdat 'set-test-start-time (list test-id)))
- (if msg
- (db:general-call dbdat 'state-status-msg (list state status msg test-id))
- (db:general-call dbdat 'state-status (list state status test-id)))
- (mt:process-triggers run-id test-id state status)))
+ ;; (if msg
+ ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
+ ;; (db:general-call dbdat 'state-status (list state status test-id)))
+ (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
+ ;; process the test_data table
+ (if (and test-id state status (equal? status "AUTO"))
+ (db:test-data-rollup dbstruct run-id test-id status))
+ (mt:process-triggers run-id test-id state status)))
+
+;; state is the priority rollup of all states
+;; status is the priority rollup of all completed statesfu
+;;
+;; if test-name is an integer work off that instead of test-name test-path
+;;
+(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
+ ;; establish info on incoming test followed by info on top level test
+ (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct)))
+ (testdat (if (number? test-name)
+ (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
+ (db:get-test-info dbstruct run-id test-name item-path)))
+ (test-id (db:test-get-id testdat))
+ (test-name (if (number? test-name)
+ (db:test-get-testname testdat)
+ test-name))
+ (item-path (db:test-get-item-path testdat))
+ (tl-testdat (db:get-test-info dbstruct run-id test-name ""))
+ (tl-test-id (db:test-get-id tl-testdat)))
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (db:test-set-state-status-by-id dbstruct run-id test-id state status comment)
+ (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
+ (let* ((all-curr-states (common:special-sort
+ (delete-duplicates
+ (let ((states (db:get-all-item-states db run-id test-name)))
+ (if state (cons state states) states)))
+ *common:std-states* >))
+ (all-curr-statuses (common:special-sort
+ (delete-duplicates
+ (let ((statuses (db:get-all-item-statuses db run-id test-name)))
+ (if (member state *common:ended-states*) ;; '("COMPLETED" "ARCHIVED"))
+ (cons (if (member state *common:badly-ended-states*)
+ "FAIL"
+ status)
+ statuses)
+ statuses)))
+ *common:std-statuses* >))
+ (newstate (if (null? all-curr-states) "NOT_STARTED" (car all-curr-states)))
+ (newstatus (if (null? all-curr-statuses) "n/a" (car all-curr-statuses))))
+ ;; (print "Setting toplevel to: " newstate "/" newstatus)
+ (db:test-set-state-status-by-id dbstruct run-id tl-test-id newstate newstatus #f)))))))
+
+(define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items)
;; call with state = #f to roll up with out accounting for state/status of this item
;;
-(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status)
- (if (not (equal? item-path ""))
- (let ((dbdat (db:get-db dbstruct run-id)))
- ;; (db (db:dbdat-get-db dbdat)))
- (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name))
- (db:top-test-set-per-pf-counts dbstruct run-id test-name))))
-
-;; (case (string->symbol status)
-;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name)))
-;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
-;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
-
-;; (if (or (not state)
-;; (not (equal? item-path "")))
-;; ;; just do a rollup
-;; (begin
-;; (db:top-test-set-per-pf-counts dbdat run-id test-name)
-;; #f)
-;; (begin
-;; ;; NOTE: No else clause needed for this case
-;; (case (string->symbol status)
-;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name)))
-;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
-;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
-;; #f)
-;; )))
+;; (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status)
+;; (if (not (equal? item-path "")) ;; if asked to do this for a specific item then do an incremental update
+;; (let* ((dbdat (db:get-db dbstruct run-id))
+;; (toptestdat (db:get-test-info dbstruct run-id test-name item-path))
+;; (currtopstate (db:test-get-state toptestdat))
+;; (currtopstatus (db:test-get-status toptestdat))
+;; (nextss (common:apply-state-status currtopstate currtopstatus state status))
+;; (newtopstate (car nextss)) ;; #f or a symbol
+;; (newtopstatus (cdr nextss))) ;; #f or a symbol
+;; (if (not newtopstate) ;; need to calculate it
+;;
+;; ;; We rely on the toplevel to track status as state varies. I.e. preserve an ABORT
+;;
+;;
+;; ;; (db (db:dbdat-get-db dbdat)))
+;; (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name))
+;; (db:top-test-set-per-pf-counts dbstruct run-id test-name))))
+;;
+;; ;; (case (string->symbol status)
+;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name)))
+;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
+;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
+;;
+;; ;; (if (or (not state)
+;; ;; (not (equal? item-path "")))
+;; ;; ;; just do a rollup
+;; ;; (begin
+;; ;; (db:top-test-set-per-pf-counts dbdat run-id test-name)
+;; ;; #f)
+;; ;; (begin
+;; ;; ;; NOTE: No else clause needed for this case
+;; ;; (case (string->symbol status)
+;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name)))
+;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
+;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
+;; ;; #f)
+;; ;; )))
+
+(define (db:get-all-item-states db run-id test-name)
+ (sqlite3:map-row
+ (lambda (a) a)
+ db
+ "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
+ run-id test-name))
+
+(define (db:get-all-item-statuses db run-id test-name)
+ (sqlite3:map-row
+ (lambda (a) a)
+ db
+ "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
+ run-id test-name))
(define (db:test-get-logfile-info dbstruct run-id test-name)
(db:with-db
dbstruct
run-id
@@ -3150,12 +3228,12 @@
(set! res (list path final_logf))
(if (directory? path)
(debug:print 2 *default-log-port* "Found path: " path)
(debug:print 2 *default-log-port* "No such path: " path))) ;; )
db
- "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';"
- test-name)
+ "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;"
+ test-name run-id)
res))))
;;======================================================================
;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S
;;======================================================================
@@ -3184,11 +3262,11 @@
ELSE status
END WHERE id=?;") ;; DONE
'(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE
;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE
;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
- '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;")
+ '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id
'(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE
"UPDATE tests SET state='DELETED' WHERE state=?")
'(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
'(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
@@ -3196,13 +3274,12 @@
'(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
;; stuff for roll-up-pass-fail-counts
'(update-pass-fail-counts "UPDATE tests
SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
- WHERE testname=? AND item_path='';") ;; DONE
- '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE
- '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE
+ WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
+ '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this:
;;
;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status;
@@ -3288,11 +3365,11 @@
AND item_path != ''
AND state = 'COMPLETED'
AND status = 'PASS') > 0 THEN 'PASS'
WHEN pass_count > 0 AND fail_count=0 THEN 'PASS'
ELSE 'UNKNOWN' END
- WHERE testname=? AND item_path='';") ;; DONE
+ WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id
;; STEPS
'(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
'(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
))
@@ -3310,16 +3387,16 @@
sync
set-verbosity
killserver
))
-(define (db:login dbstruct calling-path calling-version run-id client-signature)
+(define (db:login dbstruct calling-path calling-version client-signature)
(cond
((not (equal? calling-path *toppath*))
(list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
- ((not (equal? *run-id* run-id))
- (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
+ ;; ((not (equal? *run-id* run-id))
+ ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
((not (equal? megatest-version calling-version))
(list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version))
(else
(hash-table-set! *logged-in-clients* client-signature (current-seconds))
'(#t "successful login"))))
@@ -3328,11 +3405,11 @@
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(apply sqlite3:execute (db:dbdat-get-db dbdat) query params)
#t))
;; get a summary of state and status counts to calculate a rollup
;;
@@ -3380,17 +3457,17 @@
;; Run this remotely!!
;;
(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
(let* ((dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat))
- (keys (db:get-keys db))
+ (keys (db:get-keys dbstruct))
(selstr (string-intersperse keys ","))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (a . b)
(set! keyvals (cons a b)))
db
(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
DELETED debugger.scm
Index: debugger.scm
==================================================================
--- debugger.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-(use iup)
-
-(define *debugger-control* #f)
-(define *debugger-rownum* 0)
-(define *debugger-matrix* #f)
-(define *debugger* #f)
-
-(define (debugger)
- (if (not *debugger*)
- (set! *debugger*
- (thread-start!
- (make-thread
- (lambda ()
- (show
- (dialog
- (let ((pause #f)
- (mtrx (matrix
- #:expand "YES"
- #:numlin 30
- #:numcol 3
- #:numlin-visible 20
- #:numcol-visible 2
- #:alignment1 "ALEFT"
- )))
- (set! pause (button "Pause"
- #:action (lambda (obj)
- (set! *debugger-control* (not *debugger-control*))
- (attribute-set! pause "BGCOLOR" (if *debugger-control*
- "200 0 0"
- "0 0 200")))))
- (set! *debugger-matrix* mtrx)
- (attribute-set! mtrx "WIDTH1" "300")
- (vbox
- mtrx
- (hbox
- pause)))))
- (main-loop)))))))
-
-(define (debugger-start #!key (start 2))
- (set! *debugger-rownum* start))
-
-(define (debugger-trace-var varname varval)
- (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1")))
- (newval (conc varval)))
- (if (not (equal? oldval newval))
- (begin
- ;; (print "DEBUG: " varname " = " newval)
- (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname)
- (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval))
- ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1")
- ))
- (set! *debugger-rownum* (+ *debugger-rownum* 1))))
-
-
-(define (debugger-pauser)
- (debugger)
- (attribute-set! *debugger-matrix* "REDRAW" "ALL")
- (let loop ()
- (if *debugger-control*
- (begin
- (print "PAUSED!")
- (thread-sleep! 1)
- (loop))
- ;;(thread-sleep! 0.01)
- )))
-
-;; ;; lets use the debugger eh?
-;; (debugger-start)
-;; (debugger-trace-var "can-run-more" can-run-more)
-;; (debugger-trace-var "hed" hed)
-;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met))
-;; (debugger-pauser)
-
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: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ fs-transport.scm
@@ -35,10 +35,10 @@
;; There is no "server" per se but a convience routine to make it non
;; necessary to be reopening the db over and over again.
;;
(define (fs:process-queue-item packet)
- (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called
- (set! *megatest-db* (open-db)))
+ (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
+ (set! *dbstruct-db* (db:setup-db)))
(debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *megatest-db* packet))
+ (db:process-queue-item *dbstruct-db* packet))
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -36,11 +36,10 @@
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
-(define *heartbeat-mutex* (make-mutex))
;;======================================================================
;; S E R V E R
;;======================================================================
@@ -58,11 +57,10 @@
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (configf:lookup *configdat* "setup" "linktree")))
- ;; (set! db *inmemdb*)
(debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
(handle-directory spiffy-directory-listing)
@@ -82,14 +80,14 @@
(dat ($ 'dat))
(res #f))
(cond
((equal? (uri-path (request-uri (current-request)))
'(/ "api"))
- (send-response body: (api:process-request *inmemdb* $) ;; the $ is the request vars proc
+ (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
headers: '((content-type text/plain)))
(mutex-lock! *heartbeat-mutex*)
- (set! *last-db-access* (current-seconds))
+ (set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
((equal? (uri-path (request-uri (current-request)))
'(/ ""))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
@@ -112,11 +110,11 @@
;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server run-id ipaddrstr portnum server-id)
(let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
(tdbdat (tasks:open-db)))
- (debug:print-info 0 *default-log-port* "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
+ (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
(handle-exceptions
exn
(begin
(print-error-message exn)
(if (< portnum 64000)
@@ -261,11 +259,11 @@
exn
(begin
(set! success #f)
(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (hash-table-delete! *runremote* run-id)
+ (set! *runremote* #f) ;; (hash-table-delete! *runremote* run-id)
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
;;; (signal (make-composite-condition
;;; (make-property-condition 'commfail 'message "failed to connect to server")))
@@ -308,11 +306,11 @@
'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
;; careful closing of connections stored in *runremote*
;;
(define (http-transport:close-connections run-id)
- (let* ((server-dat (hash-table-ref/default *runremote* run-id #f)))
+ (let* ((server-dat *runremote*)) ;; (hash-table-ref/default *runremote* run-id #f)))
(if (vector? server-dat)
(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
(close-connection! api-dat)
#t)
#f)))
@@ -393,51 +391,27 @@
(server-timeout (server:get-timeout)))
(let loop ((count 0)
(server-state 'available)
(bad-sync-count 0))
- ;; Use this opportunity to sync the inmemdb to db
- (if *inmemdb*
- (let ((start-time (current-milliseconds))
- (sync-time #f)
- (rem-time #f))
- ;; inmemdb is a dbstruct
- (condition-case
- (db:sync-touched *inmemdb* *run-id* force-sync: #t)
- ((sync-failed)(cond
- ((> bad-sync-count 10) ;; time to give up
- (http-transport:server-shutdown server-id port))
- (else ;; (> bad-sync-count 0) ;; we've had a fail or two, delay and loop
- (thread-sleep! 5)
- (loop count server-state (+ bad-sync-count 1)))))
- ((exn)
- (debug:print-error 0 *default-log-port* "error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server")
- (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed")
- (exit)))
- (set! sync-time (- (current-milliseconds) start-time))
- (set! rem-time (quotient (- 4000 sync-time) 1000))
- (debug:print 4 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time)
-
- (if (and (<= rem-time 4)
- (> rem-time 0))
- (thread-sleep! rem-time)
- (thread-sleep! 4))) ;; fallback for if the math is changed ...
-
- ;;
- ;; no *inmemdb* yet, set running after our first pass through and start the db
- ;;
+ ;; Use this opportunity to sync the tmp db to megatest.db
+ (if *dbstruct-db*
+ (let ((start-time (current-milliseconds))
+ (sync-time #f)
+ (rem-time #f))
+ (thread-sleep! 4))
+ ;; Removed code is pasted below (keeping it around until we are clear it is not needed).
+ ;; no *dbstruct-db* yet, set running after our first pass through and start the db
(if (eq? server-state 'available)
(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))
- ;; force initialization
- ;; (db:get-db *inmemdb* #t)
- (db:get-db *inmemdb* run-id)
- (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running"))
+ (set! *dbstruct-db* (db:setup)) ;; run-id))
+ (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
+ (server:write-dotserver *toppath* (conc iface ":" port)))
(begin ;; gotta exit nicely
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
(http-transport:server-shutdown server-id port))))))
(if (< count 1) ;; 3x3 = 9 secs aprox
@@ -453,13 +427,13 @@
(begin
(debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info")
(set! iface (car sdat))
(set! port (cadr sdat))))
- ;; Transfer *last-db-access* to last-access to use in checking that we are still alive
+ ;; Transfer *db-last-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
- (set! last-access *last-db-access*)
+ (set! last-access *db-last-access*)
(mutex-unlock! *heartbeat-mutex*)
;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout)
;;
;; no_traffic, no running tests, if server 0, no running servers
@@ -485,17 +459,42 @@
;; (if (tasks:server-am-i-the-server? tdb run-id)
;; (tasks:server-set-state! tdb server-id "running"))
;;
(loop 0 server-state bad-sync-count))
(http-transport:server-shutdown server-id port))))))
-
+
+;; code cut out from above
+;;
+;; (condition-case
+;; ;; (if (and (member (mutex-state *db-sync-mutex*) '(abandoned not-abandoned))
+;; ;; (> (- (current-seconds) *db-last-sync*) 5)) ;; if not currently being synced nor recently synced
+;; (db:sync-touched *dbstruct-db* *run-id* force-sync: #t) ;; usually done in the watchdog, not here.
+;; ((sync-failed)(cond
+;; ((> bad-sync-count 10) ;; time to give up
+;; (http-transport:server-shutdown server-id port))
+;; (else ;; (> bad-sync-count 0) ;; we've had a fail or two, delay and loop
+;; (thread-sleep! 5)
+;; (loop count server-state (+ bad-sync-count 1)))))
+;; ((exn)
+;; (debug:print-error 0 *default-log-port* "error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server")
+;; (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed")
+;; (exit)))
+;; (set! sync-time (- (current-milliseconds) start-time))
+;; (set! rem-time (quotient (- 4000 sync-time) 1000))
+;; (debug:print 4 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time)
+;;
+;; (if (and (<= rem-time 4)
+;; (> rem-time 0))
+;; (thread-sleep! rem-time)
+;; (thread-sleep! 4))) ;; fallback for if the math is changed ...
+
(define (http-transport:server-shutdown server-id port)
(let ((tdbdat (tasks:open-db)))
(debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
- (set! *time-to-exit* #t)
- (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t))
+ ;; (if *dbstruct-db* (db:sync-touched *dbstruct-db* *run-id* force-sync: #t)) ;; handled in the watchdog only
+ (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
;;
;; start_shutdown
;;
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
(portlogger:open-run-close portlogger:set-port port "released")
@@ -515,10 +514,12 @@
(/ *total-non-write-delay*
*number-non-write-queries*))
" ms")
(debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
+ ;; if the .server file contained :myport then we can remove it
+ (server:remove-dotserver-file *toppath* port)
(exit)))
;; all routes though here end in exit ...
;;
;; start_server?
@@ -632,11 +633,11 @@
"<tr><td>Average non-cached time</td> <td>" (if (eq? *number-non-write-queries* 0)
"n/a (no queries)"
(/ *total-non-write-delay*
*number-non-write-queries*))
" ms</td></tr>"
- "<tr><td>Last access</td><td>" (seconds->time-string *last-db-access*) "</td></tr>"
+ "<tr><td>Last access</td><td>" (seconds->time-string *db-last-access*) "</td></tr>"
"</table>")))
(mutex-unlock! *heartbeat-mutex*)
res))
(define (http-transport:runs linkpath)
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -240,12 +240,12 @@
;; Since we should have a clean slate at this time there is no need to do
;; any of the other stuff that tests:test-set-status! does. Let's just
;; force RUNNING/n/a
;; (thread-sleep! 0.3)
- (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
- (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING")
+ ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
+ (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING" #f)
;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
;; if there is a runscript do it first
(if fullrunscript
(let ((pid (process-run fullrunscript)))
@@ -702,10 +702,20 @@
;; sets; *configdat* (megatest.config info)
;; *runconfigdat* (runconfigs.config info)
;; *configstatus* (status of the read data)
;;
(define (launch:setup #!key (force #f))
+ (mutex-lock! *launch-setup-mutex*)
+ (if *toppath*
+ (begin
+ (mutex-unlock! *launch-setup-mutex*)
+ *toppath*)
+ (let ((res (launch:setup-body force: force)))
+ (mutex-unlock! *launch-setup-mutex*)
+ res)))
+
+(define (launch:setup-body #!key (force #f))
(let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
(runname (common:args-get-runname))
(target (common:args-get-target))
(linktree (common:get-linktree))
(sections (if target (list "default" target) #f)) ;; for runconfigs
@@ -896,11 +906,11 @@
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))
(lnktarget (conc lnkpath "/" item-path)))
;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
;; rundir shortdir
- (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path)
+ (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id)
(debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
(if (not (file-exists? linktree))
(begin
(debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree)
@@ -969,11 +979,11 @@
(rmt:general-call 'test-set-rundir-shortdir run-id lnkpath
(if (file-exists? lnkpath)
;; (resolve-pathname lnkpath)
(common:nice-path lnkpath)
lnkpath)
- testname "")
+ testname "" run-id)
;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath)
@@ -1118,12 +1128,13 @@
(debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
(runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
;; prevent overlapping actions - set to LAUNCHED as early as possible
;;
+ ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail
(tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
- (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED")
+ (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED" #f)
(set! diskpath (get-best-disk *configdat* tconfig))
(if diskpath
(let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
(set! work-area (car dat))
(set! toptest-work-area (cadr dat))
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,62 +343,11 @@
(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))
- (debug-mode (debug:debug-mode 1))
- (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*))
- (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 11)) ;; aprox 5-6 seconds
- (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*)))))
- "Watchdog thread")))
+(define *watchdog* (make-thread common:watchdog "Watchdog thread"))
(thread-start! *watchdog*)
(if (args:get-arg "-log")
(let ((oup (open-output-file (args:get-arg "-log"))))
@@ -480,10 +433,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
@@ -681,13 +642,13 @@
(if out-file (close-output-port out-port))
(exit) ;; yes, bending the rules here - need to exit since this is a utility
))
(if (args:get-arg "-ping")
- (let* ((run-id (string->number (args:get-arg "-run-id")))
+ (let* (;; (run-id (string->number (args:get-arg "-run-id")))
(host:port (args:get-arg "-ping")))
- (server:ping run-id host:port)))
+ (server:ping host:port)))
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
@@ -772,13 +733,10 @@
;; (client:launch run-id)
;; (client:launch 0) ;; without run-id we'll start a server for "0"
#t
))))))
-;; MAY STILL NEED THIS
-;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
-
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server")
(args:get-arg "-kill-server"))
(let ((tl (launch:setup)))
(if tl
@@ -1038,11 +996,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 +1009,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 +1089,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 +1214,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)
@@ -1902,11 +1863,11 @@
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
- (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
+ (dbstruct (if toppath (db:setup)))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if dbstruct
(cond
((getenv "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
@@ -1920,11 +1881,10 @@
(repl))
(else
(begin
(set! *db* dbstruct)
- (set! *client-non-blocking-mode* #t)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
@@ -1939,11 +1899,12 @@
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))
- (db:close-all dbstruct))
+ ;; (db:close-all dbstruct) <= taken care of by on-exit call
+ )
(exit)))
(set! *didsomething* #t))))
;;======================================================================
;; Wait on a run to complete
@@ -1990,11 +1951,11 @@
;; ;; ;; redo me (set! *didsomething* #t)))
(if (args:get-arg "-import-megatest.db")
(begin
(db:multi-db-sync
- #f ;; do all run-ids
+ (db:setup)
'killservers
'dejunk
'adj-testids
'old2new
;; 'new2old
@@ -2002,11 +1963,11 @@
(set! *didsomething* #t)))
(if (args:get-arg "-sync-to-megatest.db")
(begin
(db:multi-db-sync
- #f ;; do all run-ids
+ (db:setup)
'new2old
)
(set! *didsomething* #t)))
(if (args:get-arg "-generate-html")
@@ -2018,11 +1979,11 @@
;;======================================================================
;; Exit and clean up
;;======================================================================
-(if *runremote* (close-all-connections!))
+(if *runremote* (close-all-connections!)) ;; for http-client
(if (not *didsomething*)
(debug:print 0 *default-log-port* help))
(set! *time-to-exit* #t)
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -177,25 +177,29 @@
(begin
(debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
(print-call-chain (current-error-port))
#f)
(begin
- (cond
- ((and newstate newstatus newcomment)
- (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
- ((and newstate newstatus)
- (rmt:general-call 'state-status run-id newstate newstatus test-id))
- (else
- (if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
- (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
- (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
+ ;; cond
+ ;; ((and newstate newstatus newcomment)
+ ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
+ ;; ((and newstate newstatus)
+ ;; (rmt:general-call 'state-status run-id newstate newstatus test-id))
+ ;; (else
+ ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
+ ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
+ ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
+ (rmt:roll-up-pass-fail-counts run-id test-id #f newstate newstatus newcomment)
(mt:process-triggers run-id test-id newstate newstatus)
#t)))
(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
(let ((test-id (rmt:get-test-id run-id test-name item-path)))
- (mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))
+ (rmt:roll-up-pass-fail-counts run-id test-name item-path new-state new-status new-comment)
+ (mt:process-triggers run-id test-id new-state new-status)
+ #t))
+ ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))
(define (mt:lazy-read-test-config test-name)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
(if tconf
tconf
DELETED newdashboard.scm
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ /dev/null
@@ -1,635 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, Matthew Welland.
-;;
-;; This program is made available under the GNU GPL version 2.0 or
-;; greater. See the accompanying file COPYING for details.
-;;
-;; This program is distributed WITHOUT ANY WARRANTY; without even the
-;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;; PURPOSE.
-;;======================================================================
-
-(use format numbers)
-(require-library iup)
-(import (prefix iup iup:))
-(use canvas-draw)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (uses margs))
-(declare (uses launch))
-(declare (uses megatest-version))
-(declare (uses gutils))
-(declare (uses db))
-(declare (uses server))
-(declare (uses synchash))
-(declare (uses dcommon))
-(declare (uses tree))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "key_records.scm")
-
-(define help (conc
-"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2011
-
-Usage: dashboard [options]
- -h : this help
- -server host:port : connect to host:port instead of db access
- -test testid : control test identified by testid
- -guimonitor : control panel for runs
-
-Misc
- -rows N : set number of rows
-"))
-
-;; process args
-(define remargs (args:get-args
- (argv)
- (list "-rows"
- "-run"
- "-test"
- "-debug"
- "-host"
- )
- (list "-h"
- "-guimonitor"
- "-main"
- "-v"
- "-q"
- )
- args:arg-hash
- 0))
-
-(if (args:get-arg "-h")
- (begin
- (print help)
- (exit)))
-
-(if (not (launch:setup))
- (begin
- (print "Failed to find megatest.config, exiting")
- (exit 1)))
-
-;; (if (args:get-arg "-host")
-;; (begin
-;; (set! *runremote* (string-split (args:get-arg "-host" ":")))
-;; (client:launch))
-;; (client:launch))
-
-;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
- (if (file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
-(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
- local: #t))
-(define *db-file-path* (db:dbfile-path 0))
-
-;; HACK ALERT: this is a hack, please fix.
-(define *read-only* (not (file-read-access? *db-file-path*)))
-
-(debug:setup)
-
-(define *tim* (iup:timer))
-(define *ord* #f)
-
-(iup:attribute-set! *tim* "TIME" 300)
-(iup:attribute-set! *tim* "RUN" "YES")
-
-(define (message-window msg)
- (iup:show
- (iup:dialog
- (iup:vbox
- (iup:label msg #:margin "40x40")))))
-
-(define (iuplistbox-fill-list lb items . default)
- (let ((i 1)
- (selected-item (if (null? default) #f (car default))))
- (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
- (for-each (lambda (item)
- (iup:attribute-set! lb (number->string i) item)
- (if selected-item
- (if (equal? selected-item item)
- (iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
- (set! i (+ i 1)))
- items)
- i))
-
-(define (pad-list l n)(append l (make-list (- n (length l)))))
-
-
-(define (mkstr . x)
- (string-intersperse (map conc x) ","))
-
-(define (update-search x val)
- (hash-table-set! *searchpatts* x val))
-
-;; mtest is actually the megatest.config file
-;;
-(define (mtest window-id)
- (let* ((curr-row-num 0)
- (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))
- (keys-matrix (dcommon:keys-matrix rawconfig))
- (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
- (jobtools-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 3))
- (validvals-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 2
- #:numcol-visible 1
- #:numlin-visible 2))
- (envovrd-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- (disks-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- )
- (iup:attribute-set! disks-matrix "0:0" "Disk Name")
- (iup:attribute-set! disks-matrix "0:1" "Disk Path")
- (iup:attribute-set! disks-matrix "WIDTH1" "120")
- (iup:attribute-set! disks-matrix "WIDTH0" "100")
- (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
-
- ;; fill in existing info
- (for-each
- (lambda (mat fname)
- (set! curr-row-num 1)
- (for-each
- (lambda (var)
- (iup:attribute-set! mat (conc curr-row-num ":0") var)
- (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
- (set! curr-row-num (+ curr-row-num 1)))
- (configf:section-vars rawconfig fname)))
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
- (list "setup" "jobtools" "validvalues" "env-override" "disks"))
-
- (for-each
- (lambda (mat)
- (iup:attribute-set! mat "0:1" "Value")
- (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES")
- (iup:attribute-set! mat "WIDTH1" "120")
- (iup:attribute-set! mat "WIDTH0" "100")
- )
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
-
- (iup:attribute-set! validvals-matrix "WIDTH1" "290")
- (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
-
- (iup:vbox
- (iup:hbox
-
- (iup:vbox
- (let ((tabs (iup:tabs
- ;; The required tab
- (iup:hbox
- ;; The keys
- (iup:frame
- #:title "Keys (required)"
- (iup:vbox
- (iup:label (conc "Set the fields for organising your runs\n"
- "here. Note: can only be changed before\n"
- "running the first run when megatest.db\n"
- "is created."))
- keys-matrix))
- (iup:vbox
- ;; The setup section
- (iup:frame
- #:title "Setup"
- (iup:vbox
- (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
- "linktree : directory where linktree will be created."))
- setup-matrix))
- ;; The jobtools
- (iup:frame
- #:title "Jobtools"
- (iup:vbox
- (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
- "useshell : use system to run your launcher\n"
- "workhosts : spread jobs out on these hosts"))
- jobtools-matrix))
- ;; The disks
- (iup:frame
- #:title "Disks"
- (iup:vbox
- (iup:label (conc "Enter names and existing paths of locations to run tests"))
- disks-matrix))))
- ;; The optional tab
- (iup:vbox
- ;; The Environment Overrides
- (iup:frame
- #:title "Env override"
- envovrd-matrix)
- ;; The valid values
- (iup:frame
- #:title "Validvalues"
- validvals-matrix)
- ))))
- (iup:attribute-set! tabs "TABTITLE0" "Required settings")
- (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
- tabs))
- ))))
-
-;; The runconfigs.config file
-;;
-(define (rconfig window-id)
- (iup:vbox
- (iup:frame #:title "Default")))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-(define (tree-path->test-id path)
- (if (not (null? path))
- (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
- #f))
-
-(define (test-panel window-id)
- (let* ((curr-row-num 0)
- (viewlog (lambda (x)
- (if (file-exists? logfile)
- ;(system (conc "firefox " logfile "&"))
- (iup:send-url logfile)
- (message-window (conc "File " logfile " not found")))))
- (xterm (lambda (x)
- (if (directory-exists? rundir)
- (let ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- "")))
- (system (conc "cd " rundir
- ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
- (message-window (conc "Directory " rundir " not found")))))
- (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
- (command-launch-button (iup:button "Execute!"
- ;; #:expand "HORIZONTAL"
- #:size "50x"
- #:action (lambda (x)
- (let ((cmd (iup:attribute command-text-box "VALUE")))
- (system (conc cmd " &"))))))
- (run-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
- " -runtests " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (remove-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
- " -testpatt " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (run-info-matrix (iup:matrix
- #:expand "YES"
- ;; #:scrollbar "YES"
- #:numcol 1
- #:numlin 4
- #:numcol-visible 1
- #:numlin-visible 4
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status))))
- (test-info-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 7
- #:numcol-visible 1
- #:numlin-visible 7))
- (test-run-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (meta-dat-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (steps-matrix (iup:matrix
- #:expand "YES"
- #:numcol 6
- #:numlin 50
- #:numcol-visible 6
- #:numlin-visible 8))
- (data-matrix (iup:matrix
- #:expand "YES"
- #:numcol 8
- #:numlin 50
- #:numcol-visible 8
- #:numlin-visible 8))
- (updater (lambda (testdat)
- (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
-
- ;; Set the updater in updaters
- (hash-table-set! (dboard:data-updaters *data*) window-id updater)
- ;;
- (for-each
- (lambda (mat)
- ;; (iup:attribute-set! mat "0:1" "Value")
- ;; (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "HEIGHT0" 0)
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
- ;; (iup:attribute-set! mat "WIDTH1" "120")
- ;; (iup:attribute-set! mat "WIDTH0" "100"))
- (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
-
- ;; Steps matrix
- (iup:attribute-set! steps-matrix "0:1" "Step Name")
- (iup:attribute-set! steps-matrix "0:2" "Start")
- (iup:attribute-set! steps-matrix "WIDTH2" "40")
- (iup:attribute-set! steps-matrix "0:3" "End")
- (iup:attribute-set! steps-matrix "WIDTH3" "40")
- (iup:attribute-set! steps-matrix "0:4" "Status")
- (iup:attribute-set! steps-matrix "WIDTH4" "40")
- (iup:attribute-set! steps-matrix "0:5" "Duration")
- (iup:attribute-set! steps-matrix "WIDTH5" "40")
- (iup:attribute-set! steps-matrix "0:6" "Log File")
- (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
- ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
- ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
-
- ;; Data matrix
- ;;
- (let ((rownum 1))
- (for-each
- (lambda (x)
- (iup:attribute-set! data-matrix (conc "0:" rownum) x)
- (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
- (set! rownum (+ rownum 1)))
- (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
- (iup:attribute-set! data-matrix "REDRAW" "ALL")
-
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (keys (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (iup:attribute-set! mat (conc rownum ":0") key)
- (set! rownum (+ rownum 1)))
- keys)
- (iup:attribute-set! mat "REDRAW" "ALL")))
- (list
- (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
- (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
- (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
- (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
-
- (iup:split
- #:orientation "HORIZONTAL"
- (iup:vbox
- (iup:hbox
- (iup:vbox
- run-info-matrix
- test-info-matrix)
- ;; test-info-matrix)
- (iup:vbox
- test-run-matrix
- meta-dat-matrix))
- (iup:vbox
- (iup:vbox
- (iup:hbox
- (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
- (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
- (iup:hbox
- (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
- (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
- (iup:hbox
- ;; hiup:split ;; hbox
- ;; #:orientation "HORIZONTAL"
- ;; #:value 300
- command-text-box
- command-launch-button)))
- (iup:vbox
- (let ((tabs (iup:tabs
- steps-matrix
- data-matrix)))
- (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
- (iup:attribute-set! tabs "TABTITLE1" "Test Data")
- tabs)))))
-
-;; Test browser
-(define (tests window-id)
- (iup:split
- (let* ((tb (iup:treebox
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((run-path (tree:node->path obj id))
- (test-id (tree-path->test-id (cdr run-path))))
- (if test-id
- (hash-table-set! (dboard:data-curr-test-ids *data*)
- window-id test-id))
- (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
- (iup:attribute-set! tb "VALUE" "0")
- (iup:attribute-set! tb "NAME" "Runs")
- ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
- (dboard:data-tests-tree-set! *data* tb)
- tb)
- (test-panel window-id)))
-
-;; The function to update the fields in the test view panel
-(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
- ;; get test-id
- ;; then get test record
- (if testdat
- (let* ((test-id (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
- (test-data (hash-table-ref/default testdat test-id #f))
- (run-id (db:test-get-run_id test-data))
- (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
- run-id
- '()))
- (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
- (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
- (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
-
- (if test-data
- (begin
- ;;
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (vals (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (let ((cell (conc rownum ":1")))
- (if (not (equal? (iup:attribute mat cell)(conc key)))
- (begin
- ;; (print "setting cell " cell " in matrix " mat " to value " key)
- (iup:attribute-set! mat cell (conc key))
- (iup:attribute-set! mat "REDRAW" cell)))
- (set! rownum (+ rownum 1))))
- vals)))
- (list
- (list run-info-matrix
- (if test-id
- (list (db:test-get-run_id test-data)
- target
- runname
- "n/a")
- (make-list 4 "")))
- (list test-info-matrix
- (if test-id
- (list test-id
- (db:test-get-testname test-data)
- (db:test-get-item-path test-data)
- (db:test-get-state test-data)
- (db:test-get-status test-data)
- (seconds->string (db:test-get-event_time test-data))
- (db:test-get-comment test-data))
- (make-list 7 "")))
- (list test-run-matrix
- (if test-id
- (list (db:test-get-host test-data)
- (db:test-get-uname test-data)
- (db:test-get-diskfree test-data)
- (db:test-get-cpuload test-data)
- (seconds->hr-min-sec (db:test-get-run_duration test-data)))
- (make-list 5 "")))
- ))
- (dcommon:populate-steps steps-dat steps-matrix))))))
- ;;(list meta-dat-matrix
- ;; (if test-id
- ;; (list (
-
-
-;; db:test-get-id
-;; db:test-get-run_id
-;; db:test-get-testname
-;; db:test-get-state
-;; db:test-get-status
-;; db:test-get-event_time
-;; db:test-get-host
-;; db:test-get-cpuload
-;; db:test-get-diskfree
-;; db:test-get-uname
-;; db:test-get-rundir
-;; db:test-get-item-path
-;; db:test-get-run_duration
-;; db:test-get-final_logf
-;; db:test-get-comment
-;; db:test-get-fullname
-
-
-;;======================================================================
-;; R U N C O N T R O L
-;;======================================================================
-
-;; Overall runs browser
-;;
-(define (runs window-id)
- (let* ((runs-matrix (iup:matrix
- #:expand "YES"
- ;; #:fittosize "YES"
- #:scrollbar "YES"
- #:numcol 100
- #:numlin 100
- #:numcol-visible 7
- #:numlin-visible 7
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
-
- (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
- (iup:attribute-set! runs-matrix "WIDTH0" "100")
-
- (dboard:data-runs-matrix-set! *data* runs-matrix)
- (iup:hbox
- (iup:frame
- #:title "Runs browser"
- (iup:vbox
- runs-matrix)))))
-
-;; Browse and control a single run
-;;
-(define (runcontrol window-id)
- (iup:hbox))
-
-;;======================================================================
-;; D A S H B O A R D
-;;======================================================================
-
-;; Main Panel
-(define (main-panel window-id)
- (iup:dialog
- #:title "Megatest Control Panel"
- #:menu (dcommon:main-menu)
- #:shrink "YES"
- (let ((tabtop (iup:tabs
- (runs window-id)
- (tests window-id)
- (runcontrol window-id)
- (mtest window-id)
- (rconfig window-id)
- )))
- (iup:attribute-set! tabtop "TABTITLE0" "Runs")
- (iup:attribute-set! tabtop "TABTITLE1" "Tests")
- (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
- (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
- (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
- tabtop)))
-
-(define *current-window-id* 0)
-
-(define (newdashboard dbstruct)
- (let* ((data (make-hash-table))
- (keys (db:get-keys dbstruct))
- (runname "%")
- (testpatt "%")
- (keypatts (map (lambda (k)(list k "%")) keys))
- (states '())
- (statuses '())
- (nextmintime (current-milliseconds))
- (my-window-id *current-window-id*))
- (set! *current-window-id* (+ 1 *current-window-id*))
- (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
- (iup:show (main-panel my-window-id))
- ;; Yes, running iup:show will pop up a new panel
- ;; (iup:show (main-panel my-window-id))
- (iup:callback-set! *tim*
- "ACTION_CB"
- (lambda (x)
- ;; Want to dedicate no more than 50% of the time to this so skip if
- ;; 2x delta time has not passed since last query
- (if (< nextmintime (current-milliseconds))
- (let* ((starttime (current-milliseconds))
- (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
- (endtime (current-milliseconds)))
- (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
- (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
- (debug:print-info 11 *default-log-port* "Server overloaded"))))))
-
-(dboard:data-updaters-set! *data* (make-hash-table))
-(newdashboard *dbstruct-local*)
-(iup:main-loop)
ADDED oldsrc/debugger.scm
Index: oldsrc/debugger.scm
==================================================================
--- /dev/null
+++ oldsrc/debugger.scm
@@ -0,0 +1,73 @@
+(use iup)
+
+(define *debugger-control* #f)
+(define *debugger-rownum* 0)
+(define *debugger-matrix* #f)
+(define *debugger* #f)
+
+(define (debugger)
+ (if (not *debugger*)
+ (set! *debugger*
+ (thread-start!
+ (make-thread
+ (lambda ()
+ (show
+ (dialog
+ (let ((pause #f)
+ (mtrx (matrix
+ #:expand "YES"
+ #:numlin 30
+ #:numcol 3
+ #:numlin-visible 20
+ #:numcol-visible 2
+ #:alignment1 "ALEFT"
+ )))
+ (set! pause (button "Pause"
+ #:action (lambda (obj)
+ (set! *debugger-control* (not *debugger-control*))
+ (attribute-set! pause "BGCOLOR" (if *debugger-control*
+ "200 0 0"
+ "0 0 200")))))
+ (set! *debugger-matrix* mtrx)
+ (attribute-set! mtrx "WIDTH1" "300")
+ (vbox
+ mtrx
+ (hbox
+ pause)))))
+ (main-loop)))))))
+
+(define (debugger-start #!key (start 2))
+ (set! *debugger-rownum* start))
+
+(define (debugger-trace-var varname varval)
+ (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1")))
+ (newval (conc varval)))
+ (if (not (equal? oldval newval))
+ (begin
+ ;; (print "DEBUG: " varname " = " newval)
+ (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname)
+ (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval))
+ ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1")
+ ))
+ (set! *debugger-rownum* (+ *debugger-rownum* 1))))
+
+
+(define (debugger-pauser)
+ (debugger)
+ (attribute-set! *debugger-matrix* "REDRAW" "ALL")
+ (let loop ()
+ (if *debugger-control*
+ (begin
+ (print "PAUSED!")
+ (thread-sleep! 1)
+ (loop))
+ ;;(thread-sleep! 0.01)
+ )))
+
+;; ;; lets use the debugger eh?
+;; (debugger-start)
+;; (debugger-trace-var "can-run-more" can-run-more)
+;; (debugger-trace-var "hed" hed)
+;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met))
+;; (debugger-pauser)
+
ADDED oldsrc/newdashboard.scm
Index: oldsrc/newdashboard.scm
==================================================================
--- /dev/null
+++ oldsrc/newdashboard.scm
@@ -0,0 +1,635 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
+(use format numbers)
+(require-library iup)
+(import (prefix iup iup:))
+(use canvas-draw)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (uses margs))
+(declare (uses launch))
+(declare (uses megatest-version))
+(declare (uses gutils))
+(declare (uses db))
+(declare (uses server))
+(declare (uses synchash))
+(declare (uses dcommon))
+(declare (uses tree))
+
+(include "common_records.scm")
+(include "db_records.scm")
+(include "key_records.scm")
+
+(define help (conc
+"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+ version " megatest-version "
+ license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+ -h : this help
+ -server host:port : connect to host:port instead of db access
+ -test testid : control test identified by testid
+ -guimonitor : control panel for runs
+
+Misc
+ -rows N : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args
+ (argv)
+ (list "-rows"
+ "-run"
+ "-test"
+ "-debug"
+ "-host"
+ )
+ (list "-h"
+ "-guimonitor"
+ "-main"
+ "-v"
+ "-q"
+ )
+ args:arg-hash
+ 0))
+
+(if (args:get-arg "-h")
+ (begin
+ (print help)
+ (exit)))
+
+(if (not (launch:setup))
+ (begin
+ (print "Failed to find megatest.config, exiting")
+ (exit 1)))
+
+;; (if (args:get-arg "-host")
+;; (begin
+;; (set! *runremote* (string-split (args:get-arg "-host" ":")))
+;; (client:launch))
+;; (client:launch))
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+ (if (file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
+ local: #t))
+(define *db-file-path* (db:dbfile-path 0))
+
+;; HACK ALERT: this is a hack, please fix.
+(define *read-only* (not (file-read-access? *db-file-path*)))
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define (message-window msg)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:label msg #:margin "40x40")))))
+
+(define (iuplistbox-fill-list lb items . default)
+ (let ((i 1)
+ (selected-item (if (null? default) #f (car default))))
+ (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+ (for-each (lambda (item)
+ (iup:attribute-set! lb (number->string i) item)
+ (if selected-item
+ (if (equal? selected-item item)
+ (iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
+ (set! i (+ i 1)))
+ items)
+ i))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+ (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+ (hash-table-set! *searchpatts* x val))
+
+;; mtest is actually the megatest.config file
+;;
+(define (mtest window-id)
+ (let* ((curr-row-num 0)
+ (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))
+ (keys-matrix (dcommon:keys-matrix rawconfig))
+ (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
+ (jobtools-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 3))
+ (validvals-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 2
+ #:numcol-visible 1
+ #:numlin-visible 2))
+ (envovrd-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ (disks-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ )
+ (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+ (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+ (iup:attribute-set! disks-matrix "WIDTH1" "120")
+ (iup:attribute-set! disks-matrix "WIDTH0" "100")
+ (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+
+ ;; fill in existing info
+ (for-each
+ (lambda (mat fname)
+ (set! curr-row-num 1)
+ (for-each
+ (lambda (var)
+ (iup:attribute-set! mat (conc curr-row-num ":0") var)
+ (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+ (set! curr-row-num (+ curr-row-num 1)))
+ (configf:section-vars rawconfig fname)))
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+ (list "setup" "jobtools" "validvalues" "env-override" "disks"))
+
+ (for-each
+ (lambda (mat)
+ (iup:attribute-set! mat "0:1" "Value")
+ (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+ (iup:attribute-set! mat "WIDTH1" "120")
+ (iup:attribute-set! mat "WIDTH0" "100")
+ )
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
+
+ (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+ (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
+
+ (iup:vbox
+ (iup:hbox
+
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ ;; The required tab
+ (iup:hbox
+ ;; The keys
+ (iup:frame
+ #:title "Keys (required)"
+ (iup:vbox
+ (iup:label (conc "Set the fields for organising your runs\n"
+ "here. Note: can only be changed before\n"
+ "running the first run when megatest.db\n"
+ "is created."))
+ keys-matrix))
+ (iup:vbox
+ ;; The setup section
+ (iup:frame
+ #:title "Setup"
+ (iup:vbox
+ (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
+ "linktree : directory where linktree will be created."))
+ setup-matrix))
+ ;; The jobtools
+ (iup:frame
+ #:title "Jobtools"
+ (iup:vbox
+ (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
+ "useshell : use system to run your launcher\n"
+ "workhosts : spread jobs out on these hosts"))
+ jobtools-matrix))
+ ;; The disks
+ (iup:frame
+ #:title "Disks"
+ (iup:vbox
+ (iup:label (conc "Enter names and existing paths of locations to run tests"))
+ disks-matrix))))
+ ;; The optional tab
+ (iup:vbox
+ ;; The Environment Overrides
+ (iup:frame
+ #:title "Env override"
+ envovrd-matrix)
+ ;; The valid values
+ (iup:frame
+ #:title "Validvalues"
+ validvals-matrix)
+ ))))
+ (iup:attribute-set! tabs "TABTITLE0" "Required settings")
+ (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
+ tabs))
+ ))))
+
+;; The runconfigs.config file
+;;
+(define (rconfig window-id)
+ (iup:vbox
+ (iup:frame #:title "Default")))
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+(define (tree-path->test-id path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
+ #f))
+
+(define (test-panel window-id)
+ (let* ((curr-row-num 0)
+ (viewlog (lambda (x)
+ (if (file-exists? logfile)
+ ;(system (conc "firefox " logfile "&"))
+ (iup:send-url logfile)
+ (message-window (conc "File " logfile " not found")))))
+ (xterm (lambda (x)
+ (if (directory-exists? rundir)
+ (let ((shell (if (get-environment-variable "SHELL")
+ (conc "-e " (get-environment-variable "SHELL"))
+ "")))
+ (system (conc "cd " rundir
+ ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
+ (message-window (conc "Directory " rundir " not found")))))
+ (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
+ (command-launch-button (iup:button "Execute!"
+ ;; #:expand "HORIZONTAL"
+ #:size "50x"
+ #:action (lambda (x)
+ (let ((cmd (iup:attribute command-text-box "VALUE")))
+ (system (conc cmd " &"))))))
+ (run-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
+ " -runtests " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (remove-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
+ " -testpatt " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (run-info-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:scrollbar "YES"
+ #:numcol 1
+ #:numlin 4
+ #:numcol-visible 1
+ #:numlin-visible 4
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status))))
+ (test-info-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 7
+ #:numcol-visible 1
+ #:numlin-visible 7))
+ (test-run-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (meta-dat-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (steps-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 6
+ #:numlin 50
+ #:numcol-visible 6
+ #:numlin-visible 8))
+ (data-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 8
+ #:numlin 50
+ #:numcol-visible 8
+ #:numlin-visible 8))
+ (updater (lambda (testdat)
+ (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
+
+ ;; Set the updater in updaters
+ (hash-table-set! (dboard:data-updaters *data*) window-id updater)
+ ;;
+ (for-each
+ (lambda (mat)
+ ;; (iup:attribute-set! mat "0:1" "Value")
+ ;; (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "HEIGHT0" 0)
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
+ ;; (iup:attribute-set! mat "WIDTH1" "120")
+ ;; (iup:attribute-set! mat "WIDTH0" "100"))
+ (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
+
+ ;; Steps matrix
+ (iup:attribute-set! steps-matrix "0:1" "Step Name")
+ (iup:attribute-set! steps-matrix "0:2" "Start")
+ (iup:attribute-set! steps-matrix "WIDTH2" "40")
+ (iup:attribute-set! steps-matrix "0:3" "End")
+ (iup:attribute-set! steps-matrix "WIDTH3" "40")
+ (iup:attribute-set! steps-matrix "0:4" "Status")
+ (iup:attribute-set! steps-matrix "WIDTH4" "40")
+ (iup:attribute-set! steps-matrix "0:5" "Duration")
+ (iup:attribute-set! steps-matrix "WIDTH5" "40")
+ (iup:attribute-set! steps-matrix "0:6" "Log File")
+ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
+ ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
+ ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
+
+ ;; Data matrix
+ ;;
+ (let ((rownum 1))
+ (for-each
+ (lambda (x)
+ (iup:attribute-set! data-matrix (conc "0:" rownum) x)
+ (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
+ (set! rownum (+ rownum 1)))
+ (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
+ (iup:attribute-set! data-matrix "REDRAW" "ALL")
+
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (keys (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (iup:attribute-set! mat (conc rownum ":0") key)
+ (set! rownum (+ rownum 1)))
+ keys)
+ (iup:attribute-set! mat "REDRAW" "ALL")))
+ (list
+ (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
+ (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
+ (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
+ (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
+
+ (iup:split
+ #:orientation "HORIZONTAL"
+ (iup:vbox
+ (iup:hbox
+ (iup:vbox
+ run-info-matrix
+ test-info-matrix)
+ ;; test-info-matrix)
+ (iup:vbox
+ test-run-matrix
+ meta-dat-matrix))
+ (iup:vbox
+ (iup:vbox
+ (iup:hbox
+ (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
+ (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
+ (iup:hbox
+ (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
+ (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
+ (iup:hbox
+ ;; hiup:split ;; hbox
+ ;; #:orientation "HORIZONTAL"
+ ;; #:value 300
+ command-text-box
+ command-launch-button)))
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ steps-matrix
+ data-matrix)))
+ (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
+ (iup:attribute-set! tabs "TABTITLE1" "Test Data")
+ tabs)))))
+
+;; Test browser
+(define (tests window-id)
+ (iup:split
+ (let* ((tb (iup:treebox
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (test-id (tree-path->test-id (cdr run-path))))
+ (if test-id
+ (hash-table-set! (dboard:data-curr-test-ids *data*)
+ window-id test-id))
+ (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
+ (iup:attribute-set! tb "VALUE" "0")
+ (iup:attribute-set! tb "NAME" "Runs")
+ ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
+ (dboard:data-tests-tree-set! *data* tb)
+ tb)
+ (test-panel window-id)))
+
+;; The function to update the fields in the test view panel
+(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
+ ;; get test-id
+ ;; then get test record
+ (if testdat
+ (let* ((test-id (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
+ (test-data (hash-table-ref/default testdat test-id #f))
+ (run-id (db:test-get-run_id test-data))
+ (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
+ run-id
+ '()))
+ (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
+ (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
+ (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
+
+ (if test-data
+ (begin
+ ;;
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (vals (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (let ((cell (conc rownum ":1")))
+ (if (not (equal? (iup:attribute mat cell)(conc key)))
+ (begin
+ ;; (print "setting cell " cell " in matrix " mat " to value " key)
+ (iup:attribute-set! mat cell (conc key))
+ (iup:attribute-set! mat "REDRAW" cell)))
+ (set! rownum (+ rownum 1))))
+ vals)))
+ (list
+ (list run-info-matrix
+ (if test-id
+ (list (db:test-get-run_id test-data)
+ target
+ runname
+ "n/a")
+ (make-list 4 "")))
+ (list test-info-matrix
+ (if test-id
+ (list test-id
+ (db:test-get-testname test-data)
+ (db:test-get-item-path test-data)
+ (db:test-get-state test-data)
+ (db:test-get-status test-data)
+ (seconds->string (db:test-get-event_time test-data))
+ (db:test-get-comment test-data))
+ (make-list 7 "")))
+ (list test-run-matrix
+ (if test-id
+ (list (db:test-get-host test-data)
+ (db:test-get-uname test-data)
+ (db:test-get-diskfree test-data)
+ (db:test-get-cpuload test-data)
+ (seconds->hr-min-sec (db:test-get-run_duration test-data)))
+ (make-list 5 "")))
+ ))
+ (dcommon:populate-steps steps-dat steps-matrix))))))
+ ;;(list meta-dat-matrix
+ ;; (if test-id
+ ;; (list (
+
+
+;; db:test-get-id
+;; db:test-get-run_id
+;; db:test-get-testname
+;; db:test-get-state
+;; db:test-get-status
+;; db:test-get-event_time
+;; db:test-get-host
+;; db:test-get-cpuload
+;; db:test-get-diskfree
+;; db:test-get-uname
+;; db:test-get-rundir
+;; db:test-get-item-path
+;; db:test-get-run_duration
+;; db:test-get-final_logf
+;; db:test-get-comment
+;; db:test-get-fullname
+
+
+;;======================================================================
+;; R U N C O N T R O L
+;;======================================================================
+
+;; Overall runs browser
+;;
+(define (runs window-id)
+ (let* ((runs-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:fittosize "YES"
+ #:scrollbar "YES"
+ #:numcol 100
+ #:numlin 100
+ #:numcol-visible 7
+ #:numlin-visible 7
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+
+ (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
+ (iup:attribute-set! runs-matrix "WIDTH0" "100")
+
+ (dboard:data-runs-matrix-set! *data* runs-matrix)
+ (iup:hbox
+ (iup:frame
+ #:title "Runs browser"
+ (iup:vbox
+ runs-matrix)))))
+
+;; Browse and control a single run
+;;
+(define (runcontrol window-id)
+ (iup:hbox))
+
+;;======================================================================
+;; D A S H B O A R D
+;;======================================================================
+
+;; Main Panel
+(define (main-panel window-id)
+ (iup:dialog
+ #:title "Megatest Control Panel"
+ #:menu (dcommon:main-menu)
+ #:shrink "YES"
+ (let ((tabtop (iup:tabs
+ (runs window-id)
+ (tests window-id)
+ (runcontrol window-id)
+ (mtest window-id)
+ (rconfig window-id)
+ )))
+ (iup:attribute-set! tabtop "TABTITLE0" "Runs")
+ (iup:attribute-set! tabtop "TABTITLE1" "Tests")
+ (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
+ (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
+ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
+ tabtop)))
+
+(define *current-window-id* 0)
+
+(define (newdashboard dbstruct)
+ (let* ((data (make-hash-table))
+ (keys (db:get-keys dbstruct))
+ (runname "%")
+ (testpatt "%")
+ (keypatts (map (lambda (k)(list k "%")) keys))
+ (states '())
+ (statuses '())
+ (nextmintime (current-milliseconds))
+ (my-window-id *current-window-id*))
+ (set! *current-window-id* (+ 1 *current-window-id*))
+ (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
+ (iup:show (main-panel my-window-id))
+ ;; Yes, running iup:show will pop up a new panel
+ ;; (iup:show (main-panel my-window-id))
+ (iup:callback-set! *tim*
+ "ACTION_CB"
+ (lambda (x)
+ ;; Want to dedicate no more than 50% of the time to this so skip if
+ ;; 2x delta time has not passed since last query
+ (if (< nextmintime (current-milliseconds))
+ (let* ((starttime (current-milliseconds))
+ (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
+ (endtime (current-milliseconds)))
+ (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
+ (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
+ (debug:print-info 11 *default-log-port* "Server overloaded"))))))
+
+(dboard:data-updaters-set! *data* (make-hash-table))
+(newdashboard *dbstruct-local*)
+(iup:main-loop)
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)))
+ (let ((cinfo *runremote*)) ;; (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,125 @@
;; 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)
- )))))
+
+ ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in *runremote*
+ ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
+ ;; 3. do the query, if on homehost use local access
+ ;;
+ (if (and #f ;; FORCE NO GO FOR RIGHT NOW
+ (not *runremote*) ;; we trust *runremote* to reflect that a server was found previously
+ (not (member cmd api:read-only-queries))) ;; we don't trust so much the list of write queries
+ (let ((serverconn (server:check-if-running *toppath*)))
+ (if serverconn
+ (set! *runremote* serverconn) ;; the string can be consumed by the client setup if needed
+ (server:kind-run *toppath*))))
+
+ (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 +228,23 @@
(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 (db:setup)) ;; make-dbr:dbstruct path: dbdir local: #t)))
+ (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
@@ -246,19 +252,17 @@
(begin
(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))
+ ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
+ (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))))
+ (set! *db-last-write* start-time) ;; the oldest "write"
+ (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
@@ -309,13 +313,13 @@
(rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
-(define (rmt:login-no-auto-client-setup connection-info run-id)
- (case *transport-type*
- ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
+(define (rmt:login-no-auto-client-setup connection-info)
+ (case *transport-type* ;; run-id of 0 is just a placeholder
+ ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*)))
;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))
))
;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible
@@ -525,12 +529,12 @@
(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
(rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
;; state and status are extra hints not usually used in the calculation
;;
-(define (rmt:roll-up-pass-fail-counts run-id test-name item-path state status)
- (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path state status)))
+(define (rmt:roll-up-pass-fail-counts run-id test-name item-path state status comment)
+ (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path state status comment)))
(define (rmt:update-pass-fail-counts run-id test-name)
(rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name))
(define (rmt:top-test-set-per-pf-counts run-id test-name)
Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ rpc-transport.scm
@@ -96,11 +96,11 @@
#f))
(portnum (rpc:default-server-port))
(host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))
(tdb (tasks:open-db)))
(thread-start! th1)
- (set! db *inmemdb*)
+ (set! db *dbstruct-db*)
(open-run-close tasks:server-set-interface-port
tasks:open-db
server-id
ipaddrstr portnum)
(debug:print 0 *default-log-port* "Server started on " host:port)
@@ -116,20 +116,20 @@
(on-exit (lambda ()
(open-run-close tasks:server-set-state! tasks:open-db server-id "stopped")))
(set! *rpc:listener* rpc:listener)
(tasks:server-set-state! tdb server-id "running")
- (set! *inmemdb* (db:setup run-id))
+ (set! *dbstruct-db* (db:setup run-id))
;; if none running or if > 20 seconds since
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 5) ;; no need to do this very often
(let ((numrunning -1)) ;; (db:get-count-tests-running db)))
(if (or (> numrunning 0)
- (> (+ *last-db-access* 60)(current-seconds)))
+ (> (+ *db-last-access* 60)(current-seconds)))
(begin
- (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
+ (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *db-last-access*))
(loop (+ 1 count)))
(begin
(debug:print-info 0 *default-log-port* "Starting to shutdown the server side")
(open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop")
(thread-sleep! 10)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -222,11 +222,11 @@
;; override the number of reruns from the configs
(if (and config-reruns
(> run-count config-reruns))
(set! run-count config-reruns))
- (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
+ ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(let ((sighand (lambda (signum)
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
@@ -928,11 +928,11 @@
(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met)
(hash-table-set! test-registry hed 'removed)
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
- (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL") ;; treat as FAIL
+ (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
(list (if (null? tal)(car newtal)(car tal))
tal
reg
reruns)))))
;; can't drop this - maybe running? Just keep trying
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -34,11 +34,10 @@
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
-(define *heartbeat-mutex* (make-mutex))
;;======================================================================
;; S E R V E R
;;======================================================================
@@ -104,43 +103,28 @@
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
-(define (server:run run-id)
+(define (server:run areapath) ;; areapath is ignored for now.
(let* ((curr-host (get-host-name))
(curr-ip (server:get-best-guess-address curr-host))
+ (curr-pid (current-process-id))
(target-host (configf:lookup *configdat* "server" "homehost" ))
(testsuite (common:get-testsuite-name))
- (logfile (conc *toppath* "/logs/" run-id ".log"))
+ (logfile (conc *toppath* "/logs/server-" curr-pid ".log"))
(cmdln (conc (common:get-megatest-exe)
- " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
+ " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
(conc " -daemonize -log " logfile)
"")
- " -m testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &")))))
- (debug:print 0 *default-log-port* "INFO: Starting server (" cmdln ") as none running ...")
+ " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
+ (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")))
+ ;; we want the remote server to start in *toppath* so push there
(push-directory *toppath*)
- (if (not (directory-exists? "logs"))(create-directory "logs"))
-
- ;; Rotate logs, logic:
- ;; if > 500k and older than 1 week:
- ;; remove previous compressed log and compress this log
- ;;
- (directory-fold
- (lambda (file rem)
- (if (and (string-match "^.*.log" file)
- (> (file-size (conc "logs/" file)) 200000))
- (let ((gzfile (conc "logs/" file ".gz")))
- (if (file-exists? gzfile)
- (begin
- (debug:print-info 0 *default-log-port* "removing " gzfile)
- (delete-file gzfile)))
- (debug:print-info 0 *default-log-port* "compressing " file)
- (system (conc "gzip logs/" file)))))
- '()
- "logs")
-
+ (debug:print 0 *default-log-port* "INFO: Starting server (" cmdln ") as none running ...")
+ (thread-start! log-rotate)
+
;; host.domain.tld match host?
(if (and target-host
;; look at target host, is it host.domain.tld or ip address and does it
;; match current ip or hostname
(not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
@@ -152,11 +136,11 @@
(setenv "TARGETHOST_LOGF" logfile)
(common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
(system (conc "nbfake " cmdln))
(unsetenv "TARGETHOST_LOGF")
(if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
- ;; (system cmdln)
+ (thread-join! log-rotate)
(pop-directory)))
(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value.
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
@@ -163,91 +147,116 @@
(set! *my-client-signature* sig)
*my-client-signature*)))
;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
-(define (server:kind-run run-id)
- (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f)))
+(define (server:kind-run areapath)
+ (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f)))
(if (or (not last-run-time)
(> (- (current-seconds) last-run-time) 30))
(begin
- (server:run run-id)
- (hash-table-set! *server-kind-run* run-id (current-seconds))))))
+ (server:run areapath)
+ (hash-table-set! *server-kind-run* areapath (current-seconds))))))
;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;;
(define (server:try-running run-id)
(if (eq? run-id 0)
(server:run run-id)
(rmt:start-server run-id)))
-(define (server:check-if-running run-id)
- (let ((tdbdat (tasks:open-db)))
- (let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id))
- (trycount 0))
- (if server
- ;; note: client:start will set *runremote*. this needs to be changed
- ;; also, client:start will login to the server, also need to change that.
- ;;
- ;; client:start returns #t if login was successful.
- ;;
- (let ((res (case *transport-type*
- ((http)(server:ping-server run-id
- (tasks:hostinfo-get-interface server)
- (tasks:hostinfo-get-port server)))
- ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
- ;; (tasks:hostinfo-get-port server)
- ;; timeout: 2))
- )))
- ;; if the server didn't respond we must remove the record
+(define (server:read-dotserver areapath)
+ (let ((dotfile (conc areapath "/.server")))
+ (if (and (file-exists? dotfile)
+ (file-read-access? dotfile))
+ (with-input-from-file
+ dotfile
+ (lambda ()
+ (read-line)))
+ #f)))
+
+;; write a .server file in *toppath* with hostport
+;; return #t on success, #f otherwise
+;;
+(define (server:write-dotserver areapath hostport)
+ (let ((lock-file (conc areapath "/.server.lock"))
+ (server-file (conc areapath "/.server")))
+ (if (common:simple-file-lock lock-file)
+ (let ((res (handle-exceptions
+ exn
+ #f ;; failed for some reason, for the moment simply return #f
+ (with-output-to-file server-file
+ (lambda ()
+ (print hostport)))
+ #t)))
+ (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " created")
+ (common:simple-file-release-lock lock-file)
+ res)
+ #f)))
+
+(define (server:remove-dotserver-file areapath hostport)
+ (let ((dotserver (server:read-dotserver areapath))
+ (server-file (conc areapath "/.server"))
+ (lock-file (conc areapath "/.server.lock")))
+ (if (and dotserver (string-match (conc ".*:" hostport "$") dotserver)) ;; port matches, good enough info to decide to remove the file
+ (if (common:simple-file-lock lock-file)
+ (begin
+ (handle-exceptions
+ exn
+ #f
+ (delete-file* server-file))
+ (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed")
+ (common:simple-file-release-lock lock-file))))))
+
+;; no longer care if multiple servers are started by accident. older servers will drop off in time.
+;;
+(define (server:check-if-running areapath)
+ (let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db)))
+ (if dotserver
+ (let* ((res (case *transport-type*
+ ((http)(server:ping-server dotserver))
+ ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
+ )))
(if res
- #t
- (begin
- (debug:print-info 0 *default-log-port* "server at " server " not responding, removing record")
- (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id
- " server:check-if-running")
- res)))
- #f))))
+ dotserver
+ #f))
+ #f)))
;; called in megatest.scm, host-port is string hostname:port
;;
-(define (server:ping run-id host:port)
+;; NOTE: This is NOT called directly from clients as not all transports support a client running
+;; in the same process as the server.
+;;
+(define (server:ping host:port)
(let ((tdbdat (tasks:open-db)))
(let* ((host-port (let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f)))
- (toppath (launch:setup))
- (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
- (if (not run-id)
- (begin
- (debug:print-error 0 *default-log-port* "must specify run-id when doing ping, -run-id n")
- (print "ERROR: No run-id")
- (exit 1))
- (if (and (not host-port)
- (not server-db-dat))
- (begin
- (print "ERROR: bad host:port")
- (exit 1))
- (let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat)))
- (port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat)))
- (server-dat (http-transport:client-connect iface port))
- (login-res (rmt:login-no-auto-client-setup server-dat run-id)))
- (if (and (list? login-res)
- (car login-res))
- (begin
- (print "LOGIN_OK")
- (exit 0))
- (begin
- (print "LOGIN_FAILED")
- (exit 1)))))))))
+ (toppath (launch:setup)))
+ (if (not host-port)
+ (begin
+ (print "ERROR: bad host:port")
+ (exit 1))
+ (let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat)))
+ (port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat)))
+ (server-dat (http-transport:client-connect iface port))
+ (login-res (rmt:login-no-auto-client-setup server-dat)))
+ (if (and (list? login-res)
+ (car login-res))
+ (begin
+ (print "LOGIN_OK")
+ (exit 0))
+ (begin
+ (print "LOGIN_FAILED")
+ (exit 1))))))))
;; run ping in separate process, safest way in some cases
;;
-(define (server:ping-server run-id iface port)
+(define (server:ping-server ifaceport)
(with-input-from-pipe
- (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port))
+ (conc (common:get-megatest-exe) " -ping " ifaceport)
(lambda ()
(let loop ((inl (read-line))
(res "NOREPLY"))
(if (eof-object? inl)
(case (string->symbol res)
@@ -256,18 +265,14 @@
(else #f))
(loop (read-line) inl))))))
(define (server:login toppath)
(lambda (toppath)
- (set! *last-db-access* (current-seconds))
+ (set! *db-last-access* (current-seconds)) ;; might not be needed.
(if (equal? *toppath* toppath)
- (begin
- ;; (debug:print-info 2 *default-log-port* "login successful")
- #t)
- (begin
- ;; (debug:print-info 2 *default-log-port* "login failed")
- #f))))
+ #t
+ #f)))
(define (server:get-timeout)
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
(string->number tmo))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -353,10 +353,11 @@
(pop-directory)
result)))))
(define (tests:test-force-state-status! run-id test-id state status)
(rmt:test-set-status-state run-id test-id status state #f)
+ ;; (rmt:roll-up-pass-fail-counts run-id test-name item
(mt:process-triggers run-id test-id state status))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f))
(let* ((real-status status)
@@ -396,16 +397,17 @@
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
(rmt:test-set-status-state run-id test-id real-status state (if waived waived comment))
- (mt:process-triggers run-id test-id state real-status)))
+ ;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-status-state
+ ))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, it does remote calls under the hood.
- (if (and test-id state status (equal? status "AUTO"))
- (rmt:test-data-rollup run-id test-id status))
+ ;; (if (and test-id state status (equal? status "AUTO"))
+ ;; (rmt:test-data-rollup run-id test-id status))
;; add metadata (need to do this way to avoid SQL injection issues)
;; :first_err
;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
@@ -441,11 +443,11 @@
(rmt:csv->test-data run-id test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (not (equal? item-path ""))
- (rmt:roll-up-pass-fail-counts run-id test-name item-path state status))
+ (rmt:roll-up-pass-fail-counts run-id test-name item-path state status #f))
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
@@ -479,13 +481,12 @@
(lockf (conc outputfilename ".lock")))
(let loop ((have-lock (common:simple-file-lock lockf)))
(if have-lock
(let ((script (configf:lookup *configdat* "testrollup" test-name)))
(print "Obtained lock for " outputfilename)
- ;; (rmt:top-test-set-per-pf-counts run-id test-name)
- (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f)
- (rmt:top-test-set-per-pf-counts run-id test-name)
+ (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f #f)
+ ;; (rmt:test-set-status-state run-id test-name #f #f #f) ;; (rmt:top-test-set-per-pf-counts run-id test-name)
(if script
(system (conc script " > " outputfilename " & "))
(tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename))
(common:simple-file-release-lock lockf)
(change-directory orig-dir)
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
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -135,10 +135,10 @@
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id (cdr run-path))))
(if run-id
(begin
- (dboard:data-curr-run-id-set! *data* run-id)
+ (dboard:data-curr-run-id-set! data run-id)
(dashboard:update-run-summary-tab)))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
))))
|#
ADDED utils/find-unused-globals.sh
Index: utils/find-unused-globals.sh
==================================================================
--- /dev/null
+++ utils/find-unused-globals.sh
@@ -0,0 +1,29 @@
+#!/bin/bash
+
+echo "Finding unused globals:"
+
+for var in $(egrep '^\s*\(define\s+\*' *.scm|awk '{print $2}'|sort -u);do
+ if ! $(egrep -v '^\s*\(define' *scm| grep "$var" > /dev/null);then
+ echo "$var not used";
+ fi;
+done
+
+echo
+echo "Finding globals without proper definition in common.scm:"
+
+for var in $(egrep -v '^\s*\(define' *.scm|\
+ grep -P -v '^\s*;'|\
+ grep -P '\*[a-zA-Z]+\S+\*'|\
+ tr '*' '/' |\
+ perl -p -e 's%.*(\/\S+\/).*%$1%'|\
+ egrep '\/[a-zA-Z]+\S+\/'|\
+ sort -u);do
+ newvar=$(echo $var | tr '/' '*')
+ # echo "VAR is $var, newvar is $newvar"
+ if ! $(grep -P '^\s*\(define\s+' common.scm|\
+ grep -P -v '^\s*;'|\
+ grep "$newvar" > /dev/null);then
+ echo "$newvar not defined in common.scm"
+ fi
+done
+