Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -4,13 +4,14 @@
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
ods.scm runconfig.scm server.scm configf.scm \
db.scm keys.scm margs.scm megatest-version.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
- fs-transport.scm http-transport.scm \
+ http-transport.scm filedb.scm \
client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
- tree.scm ezsteps.scm lock-queue.scm sdb.scm
+ tree.scm ezsteps.scm lock-queue.scm sdb.scm \
+ rmt.scm api.scm tdb.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
@@ -56,10 +57,11 @@
tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm
+client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
Index: NOTES
==================================================================
--- NOTES
+++ NOTES
@@ -1,5 +1,75 @@
+======================================================================
+Try writing to in-memory db and every 2-5 seconds syncing to megatest.db
+======================================================================
+
+First, how much time will it take to write back the changes:
+
+1. Get the run table
+
+(define (get-all db)(let ((res '()))(for-each-row (lambda (a . b)(set! res (cons (apply vector a b) res))) db "SELECT * FROM tests;") res))
+(define tdata (let ((start (current-milliseconds))(res (get-all *db*)))(print (- (current-milliseconds) start))res))
+
+Result ranges from 34ms to 89ms but mostly around 40ms for 623 records on moosefs
+
+Projecting to 15000 records:
+
+ Slow 2 seconds to read all
+ Median 1 second to read all
+
+This seems like it would work with an update period of 2-5 seconds
+
+TODO
+----
+
+1. open-db opens in-memory db and megatest.db, put handles in *memdb* and *db*, *memdb* is < run-id dbh >
+2. Server is part of runtests
+ a. server start cycle - adapt to per run-id
+ i. states; starting, started, stopping, stopped
+ b. turn off write coalesing
+3. Calls to -runtests, -remove-runs etc.
+ a. Might talk to running server if run specific
+ b. Can talk to megatest.db but not a generally good idea
+ c. Can start a runserver
+4. Dashboard is fine except for writes?
+
+======================================================================
+Routines to convert for runs.scm
+
+cdb:remote-run db:register-run
+
+cdb:delete-tests-in-state *runremote*
+cdb:get-test-info-by-id *runremote*
+cdb:remote-run db:delete-old-deleted-test-records
+cdb:remote-run db:delete-run
+cdb:remote-run db:delete-test-records
+cdb:remote-run db:delete-tests-for-run
+cdb:remote-run db:find-and-mark-incomplete
+cdb:remote-run db:get-count-tests-running
+cdb:remote-run db:get-count-tests-running-in-jobgroup
+cdb:remote-run db:get-keys
+cdb:remote-run db:get-run-info
+cdb:remote-run db:get-run-key-val
+cdb:remote-run db:get-run-name-from-id
+cdb:remote-run db:get-steps-for-test
+cdb:remote-run db:get-test-id-cached
+cdb:remote-run db:get-tests-for-runs-mindata
+cdb:remote-run db:lock/unlock-run
+cdb:remote-run db:set-sync
+cdb:remote-run db:set-tests-state-status
+cdb:remote-run db:set-var
+cdb:remote-run db:testmeta-add-record
+cdb:remote-run db:testmeta-get-record
+cdb:remote-run db:testmeta-update-field
+cdb:remote-run db:update-run-event_time
+cdb:remote-run instead
+cdb:remote-run server:start
+cdb:remote-run test:get-matching-previous-test-run-records
+cdb:tests-register-test *runremote*
+(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run
+
+======================================================================
[87cbe68f31]
[be405e8e2e]
# FROM andyjpg on #chicken
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -1,4 +1,12 @@
-1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development
-2. Add a host chooser for ssh to launch-tests
-3. Try making static executable
+TODO
+====
+
+Migration to inmem db plus per run db
+-------------------------------------
+
+. Re-work the dbstruct data structure?
+.. Move main.db to global?
+.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
+. Re-work all queries to use run-id to dereference server
+. Open main.db directly in calls to -runtests etc. No need to talk remote?
ADDED api.scm
Index: api.scm
==================================================================
--- /dev/null
+++ api.scm
@@ -0,0 +1,130 @@
+;;======================================================================
+;; 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.
+;;======================================================================
+
+(declare (unit api))
+(declare (uses rmt))
+(declare (uses db))
+
+;; These are called by the server on recipt of /api calls
+
+(define (api:execute-requests dbstruct cmd params)
+ (case (string->symbol cmd)
+ ;; SERVERS
+ ((start-server) (apply server:kind-run params))
+ ;; ((kill-server)
+ ;; (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*) ;; (db:sync-to *inmemdb* *db*)
+ ;; (let ((hostname (car *runremote*))
+ ;; (port (cadr *runremote*))
+ ;; (pid (if (null? params) #f (car params)))
+ ;; (th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
+ ;; (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
+ ;; (debug:print-info 1 "current pid=" (current-process-id))
+ ;; (open-run-close tasks:server-deregister tasks:open-db
+ ;; hostname
+ ;; port: port)
+ ;; (set! *server-run* #f)
+ ;; (thread-sleep! 3)
+ ;; (if pid
+ ;; (process-signal pid signal/kill)
+ ;; (thread-start! th1))
+ ;; '(#t "exit process started")))
+
+ ;; KEYS
+ ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
+ ((get-keys) (db:get-keys dbstruct))
+
+ ;; TESTS
+ ;; json doesn't do vectors, convert to list
+ ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params))
+ ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
+ ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params))
+ ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
+ ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
+ ((delete-test-records) (apply db:delete-test-records dbstruct params))
+ ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
+ ((test-set-status-state) (apply db:test-set-status-state dbstruct params))
+ ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
+ ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
+ ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
+ ((test-get-records-for-index-file (apply db:test-get-records-for-index-file dbstruct params)))
+ ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
+ ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
+ ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
+ ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params))
+ ((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params))
+ ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
+
+ ;; RUNS
+ ((get-run-info) (apply db:get-run-info dbstruct params))
+ ((register-run) (apply db:register-run dbstruct params))
+ ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
+ ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
+ ((get-test-id) (apply db:get-test-id dbstruct params))
+ ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
+ ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
+ ((delete-run) (apply db:delete-run dbstruct params))
+ ((get-runs) (apply db:get-runs dbstruct params))
+ ((get-all-run-ids) (db:get-all-run-ids dbstruct))
+ ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
+ ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
+ ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
+ ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
+ ((update-run-event_time) (apply db:update-run-event_time dbstruct params))
+ ((find-and-mark-incompete (apply db:find-and-mark-incomplete dbstruct (car params) ovr-deadtime: (cadr params))))
+
+ ;; STEPS
+ ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
+
+ ;; TEST DATA
+ ((test-data-rollup) (apply db:test-data-rollup dbstruct params))
+ ((csv->test-data) (apply db:csv->test-data dbstruct params))
+ ((get-steps-data) (apply db:get-steps-data dbstruct params))
+
+ ;; MISC
+ ((login) (apply db:login dbstruct params))
+ ((general-call) (let ((stmtname (car params))
+ (run-id (cadr params))
+ (realparams (cddr params)))
+ (db:with-db dbstruct run-id #t ;; these are all for modifying the db
+ (lambda (db)
+ (db:general-call db stmtname realparams)))))
+ ((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t))
+ ((sdb-qry) (apply sdb:qry params))
+
+ ;; TESTMETA
+ ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
+ ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
+ ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
+ (else
+ (list "ERROR" 0))))
+
+;; http-server send-response
+;; api:process-request
+;; db:*
+;;
+;; NB// Runs on the server as part of the server loop
+;;
+(define (api:process-request dbstruct $) ;; the $ is the request vars proc
+ (let* ((cmd ($ 'cmd))
+ (paramsj ($ 'params))
+ (params (db:string->obj paramsj)) ;; (rmt:json-str->dat paramsj))
+ (res (api:execute-requests dbstruct cmd params)))
+
+ ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
+ ;; (rmt:dat->json-str
+ ;; (if (or (string? res)
+ ;; (list? res)
+ ;; (number? res)
+ ;; (boolean? res))
+ ;; res
+ ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
+ (db:obj->string res)))
+
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -35,14 +35,10 @@
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
-;; client:login serverdat
-(define (client:login serverdat)
- (cdb:login serverdat *toppath* (client:get-signature)))
-
;; Not currently used! But, I think it *should* be used!!!
(define (client:logout serverdat)
(let ((ok (and (socket? serverdat)
(cdb:logout serverdat *toppath* (client:get-signature)))))
ok))
@@ -54,38 +50,84 @@
;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;; 2. We are a run tests, list runs or other interactive process and we must figure out
;; *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
-(define (client:setup #!key (numtries 3))
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: failed to find megatest.config, exiting")
- (exit))))
- (push-directory *toppath*) ;; This is probably NOT needed
- (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)
- (let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
- (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)
- (set! *transport-type* (if hostinfo
- (string->symbol (tasks:hostinfo-get-transport hostinfo))
- 'fs))
- (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
- (case *transport-type*
- ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
- ((http)
- (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
- (tasks:hostinfo-get-port hostinfo)))
- ((zmq)
- (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
- (tasks:hostinfo-get-port hostinfo)
- (tasks:hostinfo-get-pubport hostinfo)))
- (else ;; default to fs
- (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs")
- (set! *transport-type* 'fs)
- (set! *megatest-db* (open-db))))
- (pop-directory)))
+;;
+;; lookup_server, need to remove *runremote* stuff
+;;
+(define (client:setup run-id #!key (remaining-tries 100) (failed-connects 0))
+ (debug:print-info 0 "client:setup remaining-tries=" remaining-tries)
+ (if (<= remaining-tries 0)
+ (begin
+ (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
+ (exit 1))
+ (let ((host-info (hash-table-ref/default *runremote* run-id #f)))
+ (if host-info
+ (let* ((iface (http-transport:server-dat-get-iface host-info))
+ (port (http-transport:server-dat-get-port host-info))
+ (start-res (http-transport:client-connect iface port))
+ (ping-res (rmt:login-no-auto-client-setup start-res run-id)))
+ (if ping-res ;; sucessful login?
+ (begin
+ (debug:print-info 0 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries)
+ ;; Why add the close-connections here?
+ ;; (http-transport:close-connections run-id)
+ (hash-table-set! *runremote* run-id start-res)
+ start-res) ;; return the server info
+ ;; have host info but no ping. shutdown the current connection and try again
+ (begin ;; login failed
+ (debug:print-info 0 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info)
+ (http-transport:close-connections run-id)
+ (hash-table-delete! *runremote* run-id)
+ (if (< remaining-tries 8)
+ (thread-sleep! 5)
+ (thread-sleep! 1))
+ (client:setup run-id remaining-tries: (- remaining-tries 1)))))
+ ;; YUK: rename server-dat here
+ (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
+ (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+ (if server-dat
+ (let* ((iface (tasks:hostinfo-get-interface server-dat))
+ (port (tasks:hostinfo-get-port server-dat))
+ (start-res (http-transport:client-connect iface port))
+ (ping-res (rmt:login-no-auto-client-setup start-res run-id)))
+ (if (and start-res
+ ping-res)
+ (begin
+ (hash-table-set! *runremote* run-id start-res)
+ (debug:print-info 0 "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 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
+ (http-transport:close-connections run-id)
+ (hash-table-delete! *runremote* run-id)
+ (open-run-close tasks:server-force-clean-run-record
+ tasks:open-db
+ run-id
+ (tasks:hostinfo-get-interface server-dat)
+ (tasks:hostinfo-get-port server-dat)
+ " client:setup (server-dat = #t)")
+ (thread-sleep! 2)
+ (server:try-running run-id)
+ (thread-sleep! 10) ;; give server a little time to start up
+ (client:setup run-id remaining-tries: (- remaining-tries 1)))))
+ (begin ;; no server registered
+ (let ((num-available (open-run-close tasks:num-in-available-state tasks:open-db run-id)))
+ (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
+ (thread-sleep! 2)
+ (if (< num-available 2)
+ (begin
+ ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
+ (server:try-running run-id)))
+ (thread-sleep! 10) ;; give server a little time to start up
+ (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))
+
+;; keep this as a function to ease future
+(define (client:start run-id server-info)
+ (http-transport:client-connect (tasks:hostinfo-get-interface server-info)
+ (tasks:hostinfo-get-port server-info)))
;; client:signal-handler
(define (client:signal-handler signum)
(handle-exceptions
exn
@@ -102,13 +144,16 @@
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
;; client:launch
-(define (client:launch)
+;; Need to set the signal handler somewhere other than here as this
+;; routine will go away.
+;;
+(define (client:launch run-id)
(set-signal-handler! signal/int client:signal-handler)
- (if (client:setup)
- (debug:print-info 2 "connected as client")
- (begin
- (debug:print 0 "ERROR: Failed to connect as client")
- (exit))))
+ (if (client:setup run-id)
+ (debug:print-info 2 "connected as client")
+ (begin
+ (debug:print 0 "ERROR: Failed to connect as client")
+ (exit))))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -23,15 +23,22 @@
;; (require-library margs)
;; (include "margs.scm")
(define getenv get-environment-variable)
+(define (safe-setenv key val)
+ (if (and (string? val)(string? key))
+ (handle-exceptions
+ exn
+ (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)
+ (setenv key val))
+ (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))
(define home (getenv "HOME"))
(define user (getenv "USER"))
-;; global gletches
+;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat* #f)
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
@@ -38,16 +45,19 @@
(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
+;; DATABASE
+(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs
+
;; SERVER
(define *my-client-signature* #f)
-(define *transport-type* 'fs)
+(define *transport-type* 'http)
(define *megatest-db* #f)
(define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port
-(define *runremote* #f) ;; if set up for server communication this will hold
+(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold
(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id* #f)
@@ -55,11 +65,13 @@
(define *time-to-exit* #f)
(define *received-response* #f)
(define *default-numtries* 10)
(define *server-run* #t)
(define *db-write-access* #t)
-
+(define *inmemdb* #f)
+(define *run-id* #f)
+(define *server-kind-run* (make-hash-table))
(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
@@ -91,19 +103,46 @@
(set! *test-info* (make-hash-table))
(set! *run-info-cache* (make-hash-table))
(set! *env-vars-by-run-id* (make-hash-table))
(set! *test-id-cache* (make-hash-table)))
+;; Generic string database (normalization of sorts)
+(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
+;; Generic path database (normalization of sorts)
+(define *fdb* #f)
+
+;;======================================================================
+;; U S E F U L S T U F F
+;;======================================================================
+
+(define (common:get-megatest-exe)
+ (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest"))
+
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
- (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ" "STUCK"))
+ '((0 "COMPLETED")
+ (1 "NOT_STARTED")
+ (2 "RUNNING")
+ (3 "REMOTEHOSTSTART")
+ (4 "LAUNCHED")
+ (5 "KILLED")
+ (6 "KILLREQ")
+ (7 "STUCK")))
(define *common:std-statuses*
- (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD"))
+ '((0 "PASS")
+ (1 "WARN")
+ (2 "FAIL")
+ (3 "CHECK")
+ (4 "n/a")
+ (5 "WAIVED")
+ (6 "SKIP")
+ (7 "DELETED")
+ (8 "STUCK/DEAD")))
;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym*
'(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -15,15 +15,15 @@
(cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
- (cond
+ (cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
- ((args:get-arg "-v") 2)
+ ((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
@@ -58,10 +58,11 @@
(if (debug:debug-mode n)
(with-output-to-port (current-error-port)
(lambda ()
(if *logging*
(db:log-event (apply conc params))
+ ;; (apply print "pid:" (current-process-id) " " params)
(apply print params)
)))))
(define (debug:print-info n . params)
(if (debug:debug-mode n)
@@ -68,13 +69,14 @@
(with-output-to-port (current-error-port)
(lambda ()
(let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params))))
(if *logging*
(db:log-event res)
+ ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
(apply print "INFO: (" n ") " params) ;; res)
))))))
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -205,11 +205,11 @@
(if (null? res)
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist
- key
+ key
(case allow-system
((return-procs) val-proc)
((return-string) cmd)
(else (val-proc)))))
(loop (configf:read-line inp res allow-system) curr-section-name #f #f))
@@ -218,14 +218,11 @@
(envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
(realval (if envar
(config:eval-string-in-environment val)
val)))
(debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
- (if envar
- (begin
- ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval)
- (setenv key realval)))
+ (if envar (safe-setenv key realval))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key realval))
(loop (configf:read-line inp res allow-system) curr-section-name key #f)))
(configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())))
(hash-table-set! res curr-section-name
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -24,11 +24,14 @@
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
+(declare (uses rmt))
(declare (uses ezsteps))
+;; (declare (uses sdb))
+;; (declare (uses filedb))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -152,15 +155,15 @@
;;======================================================================
;; Run info panel
;;======================================================================
-(define (run-info-panel keydat testdat runname)
+(define (run-info-panel db keydat testdat runname)
(let* ((run-id (db:test-get-run_id testdat))
- (rundat (cdb:remote-run db:get-run-info #f run-id))
+ (rundat (db:get-run-info db run-id))
(header (db:get-header rundat))
- (event_time (db:get-value-by-header (db:get-row rundat)
+ (event_time (db:get-value-by-header (db:get-rows rundat)
(db:get-header rundat)
"event_time")))
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:hbox ; #:expand "YES"
@@ -200,15 +203,18 @@
(iup:label "" #:expand "VERTICAL")))
(apply iup:vbox ; #:expand "YES"
(list
;; NOTE: Yes, the host can change!
(store-label "HostName"
- (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL")
+ (iup:label ;; (sdb:qry 'getstr
+ (db:test-get-host testdat) ;; )
+ #:expand "HORIZONTAL")
(lambda (testdat)(db:test-get-host testdat)))
(store-label "Uname"
(iup:label " " #:expand "HORIZONTAL")
- (lambda (testdat)(db:test-get-uname testdat)))
+ (lambda (testdat) ;; (sdb:qry 'getstr
+ (db:test-get-uname testdat))) ;; )
(store-label "DiskFree"
(iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL")
(lambda (testdat)(conc (db:test-get-diskfree testdat))))
(store-label "CPULoad"
(iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL")
@@ -234,22 +240,23 @@
(define *dashboard-comment-share-slot* #f)
;;======================================================================
;; Set fields
;;======================================================================
-(define (set-fields-panel test-id testdat #!key (db #f))
+(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f))
(let ((newcomment #f)
(newstatus #f)
(newstate #f)
(wtxtbox #f))
(iup:frame
#:title "Set fields"
(iup:vbox
(iup:hbox (iup:label "Comment:")
(let ((txtbox (iup:textbox #:action (lambda (val a b)
+ (rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
- (open-run-close db:test-set-state-status-by-id db test-id #f #f b)
+ (rmt:test-set-state-status-by-id run-id test-id #f #f b)
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL")))
(set! wtxtbox txtbox)
txtbox))
@@ -258,14 +265,14 @@
(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)
- (open-run-close db:test-set-state-status-by-id db test-id state #f #f)
+ (rmt:test-set-state-status-by-id run-id test-id state #f #f)
(db:test-set-state! testdat state)))))
btn))
- *common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
+ (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
(for-each
(lambda (btn)
(let* ((name (iup:attribute btn "TITLE"))
@@ -291,14 +298,14 @@
(iup:attribute-set! wtxtbox "VALUE" c)
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
- (open-run-close db:test-set-state-status-by-id db test-id #f status #f)
+ (rmt:test-set-state-status-by-id run-id test-id #f status #f)
(db:test-set-status! testdat status))))))))
btn))
- *common:std-statuses*))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
+ (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
(for-each
(lambda (btn)
(let* ((name (iup:attribute btn "TITLE"))
@@ -372,52 +379,142 @@
(let ((comment (iup:attribute comnt "VALUE"))
(test-id (db:test-get-id testdat)))
(if (or (not wpatt)
(string-match wregx comment))
(begin
- (open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment)
+ (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
(db:test-set-status! testdat "WAIVED")
(cmtcmd comment)
(iup:destroy! dlog))))))
(iup:button "Cancel"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(iup:destroy! dlog)))))))
dlog))
+
+;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!
+;;
+;; get a pretty table to summarize steps
+;;
+(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f))
+;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
+ ;; organise the steps for better readability
+ (let ((res (make-hash-table)))
+ (for-each
+ (lambda (step)
+ (debug:print 6 "step=" step)
+ (let ((record (hash-table-ref/default
+ res
+ (tdb:step-get-stepname step)
+ ;; stepname start end status Duration Logfile
+ (vector (tdb:step-get-stepname step) "" "" "" "" ""))))
+ (debug:print 6 "record(before) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))
+ (case (string->symbol (tdb:step-get-state step))
+ ((start)(vector-set! record 1 (tdb:step-get-event_time step))
+ (vector-set! record 3 (if (equal? (vector-ref record 3) "")
+ (tdb:step-get-status step)))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ ((end)
+ (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
+ (endt (any->number (vector-ref record 2))))
+ (debug:print 4 "record[1]=" (vector-ref record 1)
+ ", startt=" startt ", endt=" endt
+ ", get-status: " (tdb:step-get-status step))
+ (if (and (number? startt)(number? endt))
+ (seconds->hr-min-sec (- endt startt)) "-1")))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ (else
+ (vector-set! record 2 (tdb:step-get-state step))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (tdb:step-get-event_time step))))
+ (hash-table-set! res (tdb:step-get-stepname step) record)
+ (debug:print 6 "record(after) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))))
+ ;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
+ (sort steps (lambda (a b)
+ (cond
+ ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
+ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
+ (< (tdb:step-get-id a) (tdb:step-get-id b)))
+ (else #f)))))
+ res))
+
+(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id)
+ (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id))
+ (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
+ (map (lambda (x)
+ ;; take advantage of the \n on time->string
+ (vector
+ (vector-ref x 0)
+ (let ((s (vector-ref x 1)))
+ (if (number? s)(seconds->time-string s) s))
+ (let ((s (vector-ref x 2)))
+ (if (number? s)(seconds->time-string s) s))
+ (vector-ref x 3) ;; status
+ (vector-ref x 4)
+ (vector-ref x 5))) ;; time delta
+ (sort (hash-table-values comprsteps)
+ (lambda (a b)
+ (let ((time-a (vector-ref a 1))
+ (time-b (vector-ref b 1)))
+ (if (and (number? time-a)(number? time-b))
+ (if (< time-a time-b)
+ #t
+ (if (eq? time-a time-b)
+ (string (conc (vector-ref a 2))
+ (conc (vector-ref b 2)))
+ #f))
+ (string (conc time-a)(conc time-b)))))))))
;;======================================================================
;;
;;======================================================================
-(define (examine-test test-id) ;; run-id run-key origtest)
- (let* ((db-path (conc *toppath* "/megatest.db"))
- (db (open-db))
- (testdat (open-run-close db:get-test-info-by-id db test-id))
+(define (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: (configf:lookup *configdat* "setup" "linktree") local: #t))
+ (testdat (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)
(begin
(debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
- (let* ((run-id (if testdat (db:test-get-run_id testdat) #f))
- (keydat (if testdat (open-run-close db:get-key-val-pairs db run-id) #f))
- (rundat (if testdat (open-run-close db:get-run-info db run-id) #f))
- (runname (if testdat (db:get-value-by-header (db:get-row rundat)
+ (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f))
+ (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f))
+ (rundat (if testdat (db:get-run-info dbstruct run-id) #f))
+ (runname (if testdat (db:get-value-by-header (db:get-rows rundat)
(db:get-header rundat)
"runname") #f))
+ (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id))
;; These next two are intentional bad values to ensure errors if they should not
;; get filled in properly.
(logfile "/this/dir/better/not/exist")
(rundir (if testdat
(db:test-get-rundir testdat)
logfile))
(testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found
- (teststeps (if testdat (db:get-compressed-steps test-id work-area: rundir) '()))
+ (teststeps (if testdat (dashboard-tests:get-compressed-steps dbstruct run-id test-id) '()))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(testname (if testdat (db:test-get-testname testdat) "n/a"))
(testmeta (if testdat
- (let ((tm (open-run-close db:testmeta-get-record db testname)))
+ (let ((tm (db:testmeta-get-record dbstruct testname)))
(if tm tm (make-db:testmeta)))
(make-db:testmeta)))
(keystring (string-intersperse
(map (lambda (keyval)
@@ -452,44 +549,28 @@
(if (file-exists? testdat-path)
(file-modification-time testdat-path)
(begin
(set! testdat-path (conc rundir "/testdat.db"))
0))))
- (need-update (or (and (> curr-mod-time db-mod-time)
+ (need-update (or (and (>= curr-mod-time db-mod-time)
(> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
(> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds
request-update))
(newtestdat (if need-update
;; NOTE: BUG HIDER, try to eliminate this exception handler
(handle-exceptions
exn
- (debug:print-info 0 "WARNING: test db access issue for test " test-id ": " ((condition-property-accessor 'exn 'message) exn))
- (make-db:test)
- (let* ((newdat (open-run-close db:get-test-info-by-id db test-id ))
- (tstdat (if newdat
- (open-run-close tests:testdat-get-testinfo db test-id #f)
- '())))
- (if (and newdat
- (not (null? tstdat))) ;; (update-time cpuload diskfree run-duration)
- (let* ((rec (car tstdat))
- (cpuload (vector-ref rec 1))
- (diskfree (vector-ref rec 2))
- (run-dur (vector-ref rec 3)))
- (db:test-set-run_duration! newdat run-dur)
- (db:test-set-diskfree! newdat diskfree)
- (db:test-set-cpuload! newdat cpuload)))
- ;; (debug:print 0 "newdat=" newdat)
- newdat)
- )
- #f)))
- ;; (debug:print 0 "newtestdat=" newtestdat)
+ (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
+ (db:get-test-info-by-id dbstruct run-id test-id )))))
+ ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time)
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
- (set! teststeps (db:get-compressed-steps test-id work-area: rundir))
+ (set! teststeps (dashboard-tests:get-compressed-steps dbstruct run-id test-id))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
- (set! rundir (db:test-get-rundir testdat))
+ (set! rundir ;; (filedb:get-path *fdb*
+ (db:test-get-rundir testdat)) ;; )
(set! testfullname (db:test-get-fullname testdat))
;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n "))
;; I don't see why this was implemented this way. Please comment it ...
;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
@@ -600,11 +681,11 @@
(iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title testfullname
(iup:vbox ; #:expand "YES"
;; The run and test info
(iup:hbox ; #:expand "YES"
- (run-info-panel keydat testdat runname)
+ (run-info-panel dbstruct keydat testdat runname)
(test-info-panel testdat store-label widgets)
(test-meta-panel testmeta store-meta))
(host-info-panel testdat store-label)
;; The controls
(iup:frame #:title "Actions"
@@ -618,11 +699,11 @@
(iup:button "Kill All Jobs" #:action kill-jobs #:size "80x")
(iup:button "Close" #:action (lambda (x)(exit)) #:size "80x"))
(apply
iup:hbox
(list command-text-box command-launch-button))))
- (set-fields-panel test-id testdat)
+ (set-fields-panel dbstruct run-id test-id testdat)
(let ((tabs
(iup:tabs
;; Replace here with matrix
(let ((steps-matrix (iup:matrix
#:font "Courier New, -8"
@@ -726,11 +807,11 @@
(db:test-data-get-tol x)
(db:test-data-get-status x)
(db:test-data-get-units x)
(db:test-data-get-type x)
(db:test-data-get-comment x)))
- (open-run-close db:read-test-data db test-id "%")))
+ (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%")))
"\n")))
(if (not (equal? currval newval))
(iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
test-data))
;;(dashboard:run-controls)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -39,21 +39,22 @@
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
+(include "megatest-fossil-hash.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2013
+ license GPL, Copyright (C) Matt Welland 2012-2014
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
+ -h : this help
+ -server host:port : connect to host:port instead of db access
+ -test run-id,test-id : control test identified by testid
+ -guimonitor : control panel for runs
Misc
-rows N : set number of rows
"))
@@ -63,10 +64,11 @@
(list "-rows"
"-run"
"-test"
"-debug"
"-host"
+ "-transport"
)
(list "-h"
"-use-server"
"-guimonitor"
"-main"
@@ -84,30 +86,22 @@
(if (not (setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
-(define *db* #f) ;; (open-db))
-
-(if (args:get-arg "-host")
- (begin
- (set! *runremote* (string-split (args:get-arg "-host" ":")))
- (client:launch))
- (if (not (args:get-arg "-use-server"))
- (set! *transport-type* 'fs) ;; force fs access
- (client:launch)))
+(define *dbdir* (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? (conc *toppath* "/megatest.db"))))
-;; (client:setup *db*)
+(define *read-only* (not (file-read-access? *db-file-path*)))
(define toplevel #f)
(define dlg #f)
(define max-test-num 0)
-;; (define *keys* (open-run-close db:get-keys #f))
-(define *keys* (cdb:remote-run db:get-keys #f))
-;; (define *keys* (db:get-keys *db*))
+(define *keys* (db:get-keys *dbstruct-local*))
(define *dbkeys* (append *keys* (list "runname")))
(define *header* #f)
(define *allruns* '())
@@ -116,12 +110,12 @@
(define *buttondat* (make-hash-table)) ;;
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
-(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
-;; (define *tot-run-count* (db:get-num-runs *db* "%"))
+(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
+;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
;; Update management
;;
(define *last-update* (current-seconds))
(define *last-db-update-time* 0)
@@ -137,12 +131,10 @@
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
(define *state-ignore-hash* (make-hash-table))
-(define *db-file-path* (conc *toppath* "/megatest.db"))
-
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
(vector "Sort +t" 'event_time "ASC")
(vector "Sort -t" 'event_time "DESC")
(vector "Sort +s" 'statestatus "ASC")
@@ -205,11 +197,11 @@
(null? (filter (lambda (x)(> x 3)) delta))))
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
(let* ((referenced-run-ids '())
- (allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
+ (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
*start-run-offset* keypatts))
(header (db:get-header allruns))
(runs (db:get-rows allruns))
(result '())
(maxtests 0)
@@ -224,18 +216,19 @@
;;
;; trim runs to only those that are changing often here
;;
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
- (tests (mt:get-tests-for-run run-id testnamepatt states statuses
- not-in: *hide-not-hide*
- sort-by: sort-by
- sort-order: sort-order
- qryvals: 'shortlist))
+ (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
+ #f #f
+ *hide-not-hide*
+ sort-by
+ sort-order
+ 'shortlist))
;; NOTE: bubble-up also sets the global *all-item-test-names*
;; (tests (bubble-up tmptests priority: bubble-type))
- (key-vals (cdb:remote-run db:get-key-vals #f run-id)))
+ (key-vals (db:get-key-vals *dbstruct-local* run-id)))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(set! referenced-run-ids (cons run-id referenced-run-ids))
(if (> (length tests) maxtests)
@@ -561,11 +554,11 @@
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
- (db-target-dat (open-run-close db:get-targets #f))
+ (db-target-dat (db:get-targets *dbstruct-local*))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(all-targets (append db-targets
(map (lambda (x)
(list->vector
@@ -826,11 +819,11 @@
(iup:attribute-set! tb "VALUE" val)
(dboard:data-set-run-name! *data* val)
(dashboard:update-run-command))))
(refresh-runs-list (lambda ()
(let* ((target (dboard:data-get-target-string *data*))
- (runs-for-targ (mt:get-runs-by-patt *keys* "%" target))
+ (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f))
(runs-header (vector-ref runs-for-targ 0))
(runs-dat (vector-ref runs-for-targ 1))
(run-names (cons default-run-name
(map (lambda (x)
(db:get-value-by-header x runs-header "runname"))
@@ -875,19 +868,19 @@
;; Text box for STATES
(iup:frame
#:title "States"
(dashboard:text-list-toggle-box
;; Move these definitions to common and find the other useages and replace!
- *common:std-states* ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
+ (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
(lambda (all)
(dboard:data-set-states! *data* all)
(dashboard:update-run-command))))
;; Text box for STATES
(iup:frame
#:title "Statuses"
(dashboard:text-list-toggle-box
- *common:std-statuses* ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
+ (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
(lambda (all)
(dboard:data-set-statuses! *data* all)
(dashboard:update-run-command))))))))
(iup:frame
@@ -986,21 +979,25 @@
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
-(define (dashboard:summary)
+(define (dashboard:summary db)
(let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)))
(iup:vbox
(iup:split
- ;; #:value 500
+ #:value 500
(iup:frame
#:title "General Info"
- (iup:hbox
- (dcommon:keys-matrix rawconfig)
- (dcommon:general-info)
- ))
+ (iup:vbox
+ (iup:hbox
+ (iup:label "Area Path")
+ (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
+ (iup:hbox
+ (dcommon:keys-matrix rawconfig)
+ (dcommon:general-info)
+ )))
(iup:frame
#:title "Server"
(dcommon:servers-table)))
(iup:frame
#:title "Megatest config settings"
@@ -1011,11 +1008,11 @@
;; (iup:frame
;; #:title "Disks Areas"
(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
(iup:frame
#:title "Run statistics"
- (dcommon:run-stats)))))
+ (dcommon:run-stats db)))))
;;======================================================================
;; R U N
;;======================================================================
;;
@@ -1027,11 +1024,11 @@
#f))
(define dashboard:update-run-summary-tab #f)
;; (define (tests window-id)
-(define (dashboard:one-run)
+(define (dashboard:one-run db)
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
@@ -1055,19 +1052,21 @@
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(cmd (conc toolpath " -test " test-id "&")))
(system cmd)))))
(updater (lambda ()
- (let* ((runs-dat (mt:get-runs-by-patt *keys* "%" #f))
+ (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(run-id (dboard:data-get-curr-run-id *data*))
- (tests-dat (let ((tdat (mt:get-tests-for-run run-id
+ (tests-dat (let ((tdat (db:get-tests-for-run db run-id
(hash-table-ref/default *searchpatts* "test-name" "%/%")
(hash-table-keys *state-ignore-hash*) ;; '()
(hash-table-keys *status-ignore-hash*) ;; '()
- not-in: *hide-not-hide*
- qryvals: "id,testname,item_path,state,status"))) ;; get 'em all
+ #f #f
+ *hide-not-hide*
+ #f #f
+ "id,testname,item_path,state,status"))) ;; get 'em all
(sort tdat (lambda (a b)
(let* ((aval (vector-ref a 2))
(bval (vector-ref b 2))
(anum (string->number aval))
(bnum (string->number bval)))
@@ -1184,11 +1183,11 @@
;;======================================================================
;; R U N S
;;======================================================================
-(define (make-dashboard-buttons nruns ntests keynames)
+(define (make-dashboard-buttons db nruns ntests keynames)
(let* ((nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
@@ -1229,11 +1228,11 @@
(iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
(mark-for-update)))))
(set! *hide-not-hide-button* hideit)
hideit))
(iup:hbox
- (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit)))
+ (iup:button "Quit" #:action (lambda (obj)(if *dbstruct-local* (db:close-all *dbstruct-local*))(exit)))
(iup:button "Refresh" #:action (lambda (obj)
(mark-for-update)))
(iup:button "Collapse" #:action (lambda (obj)
(let ((myname (iup:attribute obj "TITLE")))
(if (equal? myname "Collapse")
@@ -1258,21 +1257,21 @@
(mark-for-update)
(if (eq? val 1)
(hash-table-set! *status-ignore-hash* status #t)
(hash-table-delete! *status-ignore-hash* status))
(set-bg-on-filter))))
- *common:std-statuses*)) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
+ (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
(apply
iup:hbox
(map (lambda (state)
(iup:toggle state #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
(hash-table-set! *state-ignore-hash* state #t)
(hash-table-delete! *state-ignore-hash* state))
(set-bg-on-filter))))
- *common:std-states*)) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
+ (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
(oldmax (string->number (iup:attribute obj "MAX")))
(maxruns *tot-run-count*))
(set! *start-run-offset* val)
@@ -1371,11 +1370,12 @@
#:fontsize "10"
#:action (lambda (x)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref *buttondat* button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
- (cmd (conc toolpath " -test " test-id "&")))
+ (run-id (db:test-get-run_id (vector-ref buttndat 3)))
+ (cmd (conc toolpath " -test " run-id "," test-id "&")))
;(print "Launching " cmd)
(system cmd))))))
(hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f))
(vector-set! testvec testnum butn)
(loop runnum (+ testnum 1) testvec (cons butn res))))))
@@ -1395,13 +1395,13 @@
controls))
(tabs (iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
(set! *please-update-buttons* #t)
(set! *current-tab-number* curr))
- (dashboard:summary)
+ (dashboard:summary db)
runs-view
- (dashboard:one-run)
+ (dashboard:one-run db)
(dashboard:run-controls)
)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
@@ -1425,34 +1425,39 @@
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
-(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))
+(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
- (> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*))
+ (> (file-modification-time *db-file-path* *last-db-update-time*)))
(define (dashboard:set-db-update-time)
- (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))))
+ (set! *last-db-update-time* (file-modification-time *db-file-path*)))
(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)
(> (current-seconds)(+ last-db-update-time 1)))))
-(define *monitor-db-path* (conc *toppath* "/monitor.db"))
+(define *monitor-db-path* (conc *dbdir* "/monitor.db"))
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(let ((db (tasks:open-db)))
(sqlite3:finalize! db))
+(define (dashboard:get-youngest-run-db-mod-time)
+ (apply max (map (lambda (filen)
+ (file-modification-time filen))
+ (glob (conc *dbdir* "/*.db")))))
+
(define (dashboard:run-update x)
- (let* ((modtime (file-modification-time *db-file-path*))
+ (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
(monitor-modtime (if (file-exists? *monitor-db-path*)
(file-modification-time *monitor-db-path*)
-1))
(run-update-time (current-seconds))
(recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
@@ -1502,27 +1507,30 @@
(let ((runid (string->number (args:get-arg "-run"))))
(if runid
(begin
(lambda (x)
(on-exit (lambda ()
- (if *db* (sqlite3:finalize! *db*))))
- (cdb:remote-run examine-run *db* runid)))
+ (if *dbstruct-local* (db:close-all *dbstruct-local*))))
+ (examine-run *dbstruct-local* runid)))
(begin
(print "ERROR: runid is not a number " (args:get-arg "-run"))
(exit 1)))))
- ((args:get-arg "-test")
- (let ((testid (string->number (args:get-arg "-test"))))
- (if (and (number? testid)
- (>= testid 0))
- (examine-test testid)
+ ((args:get-arg "-test") ;; run-id,test-id
+ (let* ((dat (map string->number (string-split (args:get-arg "-test") ",")))
+ (run-id (car dat))
+ (test-id (cadr dat)))
+ (if (and (number? run-id)
+ (number? test-id)
+ (>= test-id 0))
+ (examine-test run-id test-id)
(begin
- (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test"))
+ (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
((args:get-arg "-guimonitor")
- (gui-monitor *db*))
+ (gui-monitor *dbstruct-local*))
(else
- (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
+ (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
(let ((update-is-running #f))
(mutex-lock! *update-mutex*)
@@ -1537,5 +1545,6 @@
(set! *update-is-running* #f)
(mutex-unlock! *update-mutex*))))
1))))
(iup:main-loop)
+(db:close-all *dbstruct-local*)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -11,97 +11,472 @@
;;======================================================================
;; Database access
;;======================================================================
-(require-extension (srfi 18) extras tcp) ;; rpc)
-;; (import (prefix rpc rpc:))
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
+(require-extension (srfi 18) extras tcp)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
-;; Note, try to remove this dependency
-;; (use zmq)
-
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
-(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
-;; timestamp type (val1 val2 ...)
-;; type: meta-info, step
-(define *incoming-writes* '())
-(define *completed-writes* (make-hash-table))
-(define *incoming-last-time* (current-seconds))
-(define *incoming-mutex* (make-mutex))
-(define *completed-mutex* (make-mutex))
-(define *cache-on* #f)
-
-(define (db:set-sync db)
- (let* ((syncval (config-lookup *configdat* "setup" "synchronous"))
- (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL;
- ((not syncval) #f)
- ((string->number syncval)
- (let ((val (string->number syncval)))
- (if (member val '(0 1 2)) val #f)))
- ((string-match (regexp "yes" #t) syncval) 1)
- ((string-match (regexp "no" #t) syncval) 0)
- ((string-match (regexp "(off|normal|full)" #t) syncval) syncval)
- (else
- (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
- #f))))
- (if val
- (begin
- (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val)
- (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))
-
-(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
- (exit))))
- (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
+(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
+(define *number-of-writes* 0)
+(define *number-non-write-queries* 0)
+
+;; Get/open a database
+;; if run-id => get run specific db
+;; 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
+ (mutex-lock! *rundb-mutex*)
+ (let ((db (if (or (not run-id)
+ (eq? run-id 0))
+ (db:open-main dbstruct)
+ (db:open-rundb dbstruct run-id)
+ )))
+ ;; db prunning would go here
+ (mutex-unlock! *rundb-mutex*)
+ db))))
+
+;; mod-read:
+;; 'mod modified data
+;; 'read read data
+;;
+(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-set-mtime! dbstruct (current-milliseconds))
+ (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds)))
+ (dbr:dbstruct-set-inuse! dbstruct #f)
+ (mutex-unlock! *rundb-mutex*))))
+
+;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
+;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
+;;
+(define (db:with-db dbstruct run-id r/w proc . params)
+ (let* ((db (db:get-db dbstruct run-id))
+ )
+ ;; (proc2 (lambda ()
+ (let ((res (apply proc db params)))
+ (db:done-with dbstruct run-id r/w)
+ res)))
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (thread-sleep! 10)
+;; (proc2))
+;; (proc2))))
+
+;;======================================================================
+;; K E E P F I L E D B I N dbstruct
+;;======================================================================
+
+;; (define (db:get-filedb dbstruct run-id)
+;; (let ((db (vector-ref dbstruct 2)))
+;; (if db
+;; db
+;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
+;; (vector-set! dbstruct 2 fdb)
+;; fdb))))
+;;
+;; ;; Can also be used to save arbitrary strings
+;; ;;
+;; (define (db:save-path dbstruct path)
+;; (let ((fdb (db:get-filedb dbstruct)))
+;; (filedb:register-path fdb path)))
+;;
+;; ;; Use to get a path. To get an arbitrary string see next define
+;; ;;
+;; (define (db:get-path dbstruct id)
+;; (let ((fdb (db:get-filedb dbstruct)))
+;; (filedb:get-path db id)))
+
+;; NB// #f => zeroth db with name=main.db
+;;
+(define (db:dbfile-path run-id)
+ (let* (;; (toppath (dbr:dbstruct-get-path dbstruct))
+ (link-tree-path (configf:lookup *configdat* "setup" "linktree"))
+ (fname (if (eq? run-id 0) "main.db" (conc run-id ".db")))
+ (dbdir (conc link-tree-path "/.db/")))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: Couldn't create path to " dbdir)
+ (exit 1))
+ (if (not (directory? dbdir))(create-directory dbdir #t)))
+ (conc dbdir fname)))
+
+;; This routine creates the db. It is only called if the db is not already opened
+;;
+(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
+ (let* ((local (dbr:dbstruct-get-local dbstruct))
+ (rdb (if local
+ (dbr:dbstruct-get-localdb dbstruct run-id)
+ (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
+ (if rdb
+ rdb
+ (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 (sqlite3:open-database dbpath))
+ (olddb (db:open-megatest-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
+ (if write-access
+ (begin
+ (if (not dbexists)
+ (begin
+ (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)
+ )) ;; add strings db to rundb, not in use yet
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 1;"))) ;; was 0 but 0 is a gamble
+ (dbr:dbstruct-set-rundb! dbstruct db)
+ (dbr:dbstruct-set-inuse! dbstruct #t)
+ (dbr:dbstruct-set-olddb! dbstruct olddb)
+ ;; (dbr:dbstruct-set-run-id! dbstruct run-id)
+ (if local
+ (begin
+ (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
+ db)
+ (begin
+ (dbr:dbstruct-set-inmem! dbstruct inmem)
+ (db:sync-tables db:sync-tests-only db inmem)
+ (dbr:dbstruct-set-refdb! dbstruct refdb)
+ (db:sync-tables db:sync-tests-only db refdb)
+ inmem))))))
+
+;; This routine creates the db. 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-get-main dbstruct)))
+ (if mdb
+ mdb
+ (let* (;; (toppath (dbr:dbstruct-get-path dbstruct))
+ ;; (link-tree-path (configf:lookup *configdat* "setup" "linktree"))
+ (dbpath (db:dbfile-path 0)) ;; (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir
+ ;; (if (not (directory-exists? dbdir))
+ ;; (create-direcory dbdir))
+ ;; (conc *toppath* "/db/main.db")))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (olddb (db:open-megatest-db))
+ (write-access (file-write-access? dbpath))
+ (handler (make-busy-timeout 136000)))
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f))
+ (if write-access
+ (begin
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")))
+ (if (not dbexists)
+ (db:initialize-main-db db))
+ ;; (dbr:dbstruct-set-run-id! dbstruct 0) ;; main.db is the zeroth "run"
+ (dbr:dbstruct-set-main! dbstruct db)
+ (dbr:dbstruct-set-olddb! dbstruct olddb)
+ db))))
+
+;; Make the dbstruct, setup up auxillary db's and call for main db at least once
+;;
+(define (db:setup run-id #!key (local #f))
+ (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+ (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
+ ;; (dbr:dbstruct-set-run-id! dbstruct run-id)
+ ;; isn't this a hold-over from the multi-db in one process? Commenting it out for now ....
+ ;; (db:get-db dbstruct #f) ;; force one call to main
+ dbstruct))
+
+;; Open the classic megatest.db file in toppath
+;;
+(define (db:open-megatest-db)
+ (let* ((dbpath (conc *toppath* "/megatest.db"))
(dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
(write-access (file-write-access? dbpath))
- (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
- (string->number (args:get-arg "-override-timeout"))
- 6000)))) ;; NB// this is in milliseconds. 136000))) ;; 136000 = 2.2 minutes
- (if (and dbexists
- (not write-access))
- (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
- (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
- (if write-access (sqlite3:set-busy-handler! db handler))
+ (handler (make-busy-timeout 136000)))
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f))
+ (if write-access
+ (begin
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")))
(if (not dbexists)
- (db:initialize db))
- ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once
- ;; (db:set-sync db)
+ (begin
+ (db:initialize-main-db db)
+ (db:initialize-run-id-db db)))
+ db))
+
+;; sync run to disk if touched
+;;
+(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
+ (let ((mtime (dbr:dbstruct-get-mtime dbstruct))
+ (stime (dbr:dbstruct-get-stime dbstruct))
+ (rundb (dbr:dbstruct-get-rundb dbstruct))
+ (inmem (dbr:dbstruct-get-inmem dbstruct))
+ (maindb (dbr:dbstruct-get-main dbstruct))
+ (refdb (dbr:dbstruct-get-refdb dbstruct))
+ (olddb (dbr:dbstruct-get-olddb dbstruct))
+ ;; (runid (dbr:dbstruct-get-run-id dbstruct))
+ )
+ (debug:print-info 0 "Syncing for run-id " run-id)
+ (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)
+ (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb)))
+ (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
+ num-synced)
+ 0)
+ (begin
+ (debug:print 0 "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)
+ (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb)))
+ (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
+ num-synced)
+ 0))))
+
+;; close all opened run-id dbs
+(define (db:close-all dbstruct)
+ ;; finalize main.db
+ (db:sync-touched dbstruct force-sync: #t)
+ (sqlite3:finalize! (db:get-db dbstruct #f))
+ (let* ((local (dbr:dbstruct-get-local dbstruct))
+ (rundb (dbr:dbstruct-get-rundb dbstruct)))
+ (if local
+ (for-each
+ (lambda (db)
+ (if (sqlite3:database? db)
+ (sqlite3:finalize! db)))
+ (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))
+ (if (sqlite3:database? rundb)
+ (sqlite3:finalize! rundb)
+ (debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database")))))
+
+(define (db:open-inmem-db)
+ (let* ((db (sqlite3:open-database ":memory:"))
+ (handler (make-busy-timeout 3600)))
+ (db:initialize-run-id-db db)
+ (sqlite3:set-busy-handler! db handler)
db))
+
+;; just tests, test_steps and test_data tables
+(define db:sync-tests-only
+ (list
+ ;; (list "strs"
+ ;; '("id" #f)
+ ;; '("str" #f))
+ (list "tests"
+ '("id" #f)
+ '("run_id" #f)
+ '("testname" #f)
+ '("host" #f)
+ '("cpuload" #f)
+ '("diskfree" #f)
+ '("uname" #f)
+ '("rundir" #f)
+ '("shortdir" #f)
+ '("item_path" #f)
+ '("state" #f)
+ '("status" #f)
+ '("attemptnum" #f)
+ '("final_logf" #f)
+ '("logdat" #f)
+ '("run_duration" #f)
+ '("comment" #f)
+ '("event_time" #f)
+ '("fail_count" #f)
+ '("pass_count" #f)
+ '("archived" #f))
+ (list "test_steps"
+ '("id" #f)
+ '("test_id" #f)
+ '("stepname" #f)
+ '("state" #f)
+ '("status" #f)
+ '("event_time" #f)
+ '("comment" #f)
+ '("logfile" #f))
+ (list "test_data"
+ '("id" #f)
+ '("test_id" #f)
+ '("category" #f)
+ '("variable" #f)
+ '("value" #f)
+ '("expected" #f)
+ '("tol" #f)
+ '("units" #f)
+ '("comment" #f)
+ '("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)))
+ (list
+ (list "keys"
+ '("id" #f)
+ '("fieldname" #f)
+ '("fieldtype" #f))
+ (list "metadat" '("var" #f) '("val" #f))
+ (append (list "runs"
+ '("id" #f))
+ (map (lambda (k)(list k #f))
+ (append keys
+ (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))))
+ (list "test_meta"
+ '("id" #f)
+ '("testname" #f)
+ '("owner" #f)
+ '("description" #f)
+ '("reviewed" #f)
+ '("iterated" #f)
+ '("avg_runtime" #f)
+ '("avg_disk" #f)
+ '("tags" #f)
+ '("jobgroup" #f)))))
+
+;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
+(define (db:sync-tables tbls fromdb todb . slave-dbs)
+ (cond
+ ((not fromdb) (debug:print 0 "ERROR: db:sync-tables called with fromdb missing") -1)
+ ((not todb) (debug:print 0 "ERROR: db:sync-tables called with todb missing") -2)
+ ((not (sqlite3:database? fromdb))
+ (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3)
+ ((not (sqlite3:database? todb))
+ (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4)
+ (else
+ (let ((stmts (make-hash-table)) ;; table-field => stmt
+ (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
+ (numrecs (make-hash-table))
+ (start-time (current-milliseconds))
+ (tot-count 0))
+ (for-each ;; table
+ (lambda (tabledat)
+ (let* ((tablename (car tabledat))
+ (fields (cdr tabledat))
+ (num-fields (length fields))
+ (field->num (make-hash-table))
+ (num->field (apply vector (map car fields)))
+ (full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
+ " FROM " tablename ";"))
+ (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
+ " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
+ (fromdat '())
+ (todat (make-hash-table))
+ (count 0))
+
+ ;; set up the field->num table
+ (for-each
+ (lambda (field)
+ (hash-table-set! field->num field count)
+ (set! count (+ count 1)))
+ fields)
+
+ ;; read the source table
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! fromdat (cons (apply vector a b) fromdat)))
+ fromdb
+ full-sel)
+
+ (debug:print 0 "INFO: found " (length fromdat) " records to sync")
+
+ ;; read the target table
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (hash-table-set! todat a (apply vector a b)))
+ todb
+ full-sel)
+
+ ;; first pass implementation, just insert all changed rows
+ (for-each
+ (lambda (targdb)
+ (let ((stmth (sqlite3:prepare targdb full-ins)))
+ (sqlite3:with-transaction
+ targdb
+ (lambda ()
+ (for-each ;;
+ (lambda (fromrow)
+ (let* ((a (vector-ref fromrow 0))
+ (curr (hash-table-ref/default todat a #f))
+ (same #t))
+ (let loop ((i 0))
+ (if (or (not curr)
+ (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
+ (set! same #f))
+ (if (and same
+ (< i (- num-fields 1)))
+ (loop (+ i 1))))
+ (if (not same)
+ (begin
+ (apply sqlite3:execute stmth (vector->list fromrow))
+ (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
+ fromdat)))
+ (sqlite3:finalize! stmth)))
+ (append (list todb) slave-dbs))))
+ tbls)
+ (let ((runtime (- (current-milliseconds) start-time)))
+ (debug:print 0 "INFO: db sync, total run time " runtime " ms")
+ (for-each
+ (lambda (dat)
+ (let ((tblname (car dat))
+ (count (cdr dat)))
+ (set! tot-count (+ tot-count count))
+ (if (> count 0)
+ (debug:print 0 (format #f " ~10a ~5a" tblname count)))))
+ (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
+ tot-count))))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(if (or *db-write-access*
(not (member proc *db:all-write-procs*)))
- (let* ((db (cond
- ((sqlite3:database? idb) idb)
- ((not idb) (open-db))
- ((procedure? idb) (idb))
- (else (open-db))))
+ (let* ((db (cond
+ ((sqlite3:database? idb) idb)
+ ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))
+ ((procedure? idb) (idb))
+ (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))))
(res #f))
(set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! db))
+ (if (not idb)(sqlite3:finalize! dbstruct))
(debug:print-info 11 "open-run-close-no-exception-handling END" )
res)
#f))
(define (open-run-close-exception-handling proc idb . params)
@@ -121,37 +496,17 @@
(thread-sleep! sleep-time)
(debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
(apply open-run-close-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
-;; (define open-run-close open-run-close-exception-handling)
+;; (define open-run-close
(define open-run-close open-run-close-exception-handling)
-
-(define *global-delta* 0)
-(define *last-global-delta-printed* 0)
-
-(define (open-run-close-measure proc idb . params)
- (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params)
- (let* ((start-ms (current-milliseconds))
- (db (if idb idb (open-db)))
- (throttle (string->number (config-lookup *configdat* "setup" "throttle"))))
- ;; (db:set-sync db)
- (set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! db))
- ;; scale by 10, average with current value.
- (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
- (if throttle throttle 0.01)))
- 2))
- (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
- (begin
- (debug:print-info 1 "launch throttle factor=" *global-delta*)
- (set! *last-global-delta-printed* *global-delta*)))
- (debug:print-info 11 "open-run-close-measure END" )
- res))
-
-(define (db:initialize db)
- (debug:print-info 11 "db:initialize START")
+ ;; open-run-close-no-exception-handling
+;; open-run-close-exception-handling)
+;;)
+
+(define (db:initialize-main-db db)
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys->key/field keys)))
@@ -159,75 +514,31 @@
(let ((keyn key))
(if (member (string-downcase keyn)
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
"pass_count"))
(begin
- (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table")
- (system (conc "rm -f " dbpath))
+ (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.")
(exit 1)))))
keys)
- ;; (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (db:set-sync db)
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
(for-each (lambda (key)
(sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
keys)
(sqlite3:execute db (conc
- "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, "
- fieldstr (if havekeys "," "")
- "runname TEXT,"
- "state TEXT DEFAULT '',"
- "status TEXT DEFAULT '',"
- "owner TEXT DEFAULT '',"
- "event_time TIMESTAMP,"
- "comment TEXT DEFAULT '',"
- "fail_count INTEGER DEFAULT 0,"
- "pass_count INTEGER DEFAULT 0,"
- "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
- (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
- (sqlite3:execute db
- "CREATE TABLE IF NOT EXISTS tests
- (id INTEGER PRIMARY KEY,
- run_id INTEGER,
- testname TEXT,
- host TEXT DEFAULT 'n/a',
- cpuload REAL DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- uname TEXT DEFAULT 'n/a',
- rundir TEXT DEFAULT 'n/a',
- shortdir TEXT DEFAULT '',
- item_path TEXT DEFAULT '',
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'FAIL',
- attemptnum INTEGER DEFAULT 0,
- final_logf TEXT DEFAULT 'logs/final.log',
- logdat BLOB,
- run_duration INTEGER DEFAULT 0,
- comment TEXT DEFAULT '',
- event_time TIMESTAMP,
- fail_count INTEGER DEFAULT 0,
- pass_count INTEGER DEFAULT 0,
- archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
- CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
- );")
- (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);")
- (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
- (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- stepname TEXT,
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'n/a',
- event_time TIMESTAMP,
- comment TEXT DEFAULT '',
- logfile TEXT DEFAULT '',
- CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY,
+ "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
+ fieldstr (if havekeys "," "") "
+ runname TEXT DEFAULT 'norun',
+ state TEXT DEFAULT '',
+ status TEXT DEFAULT '',
+ owner TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ comment TEXT DEFAULT '',
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
+ id INTEGER PRIMARY KEY,
testname TEXT DEFAULT '',
author TEXT DEFAULT '',
owner TEXT DEFAULT '',
description TEXT DEFAULT '',
reviewed TIMESTAMP,
@@ -235,10 +546,69 @@
avg_runtime REAL,
avg_disk REAL,
tags TEXT DEFAULT '',
jobgroup TEXT DEFAULT 'default',
CONSTRAINT test_meta_constraint UNIQUE (testname));")
+ (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
+ ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
+ CONSTRAINT metadat_constraint UNIQUE (var));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
+ ;; Must do this *after* running patch db !! No more.
+ ;; cannot use db:set-var since it will deadlock, hardwire the code here
+ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version)
+ (debug:print-info 11 "db:initialize END")))
+
+;;======================================================================
+;; R U N S P E C I F I C D B
+;;======================================================================
+
+(define (db:initialize-run-id-db db)
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
+ (id INTEGER PRIMARY KEY,
+ run_id INTEGER DEFAULT -1,
+ testname TEXT DEFAULT 'noname',
+ host TEXT DEFAULT 'n/a',
+ cpuload REAL DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ uname TEXT DEFAULT 'n/a',
+ rundir TEXT DEFAULT '/tmp/badname',
+ shortdir TEXT DEFAULT '/tmp/badname',
+ item_path TEXT DEFAULT '',
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'FAIL',
+ attemptnum INTEGER DEFAULT 0,
+ final_logf TEXT DEFAULT 'logs/final.log',
+ logdat TEXT DEFAULT '',
+ run_duration INTEGER DEFAULT 0,
+ comment TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
+ CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
+ (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
+ (id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ stepname TEXT,
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'n/a',
+ event_time TIMESTAMP,
+ comment TEXT DEFAULT '',
+ logfile TEXT DEFAULT '',
+ CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
+;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data
+;; (id INTEGER PRIMARY KEY,
+;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')),
+;; iterated TEXT DEFAULT '',
+;; avg_runtime REAL DEFAULT -1,
+;; avg_disk REAL DEFAULT -1,
+;; tags TEXT DEFAULT '',
+;; jobgroup TEXT DEFAULT 'default',
+;; CONSTRAINT test_meta_constraint UNIQUE (testname));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
@@ -247,124 +617,30 @@
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
- ;; Must do this *after* running patch db !! No more.
- (db:set-var db "MEGATEST_VERSION" megatest-version)
- (debug:print-info 11 "db:initialize END")
- ))
-
-;;======================================================================
-;; T E S T S P E C I F I C D B
-;;======================================================================
-
-;; Create the sqlite db for the individual test(s)
-(define (open-test-db work-area)
- (debug:print-info 11 "open-test-db " work-area)
- (if (and work-area
- (directory? work-area)
- (file-read-access? work-area))
- (let* ((dbpath (conc work-area "/testdat.db"))
- (tdb-writeable (file-write-access? dbpath))
- (dbexists (file-exists? dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
- (string->number (args:get-arg "-override-timeout"))
- 136000))))
- (handle-exceptions
- exn
- (begin
- (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
- ((condition-property-accessor 'exn 'message) exn))
- (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access
- (set! db (sqlite3:open-database dbpath)))
- (if *db-write-access* (sqlite3:set-busy-handler! db handler))
- (if (not dbexists)
- (begin
- ;; Why use FULL here? This data is not that critical
- ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
- (debug:print-info 11 "Initialized test database " dbpath)
- (db:testdb-initialize db)))
- ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
- (debug:print-info 11 "open-test-db END (sucessful)" work-area)
- ;; now let's test that everything is correct
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
- ((condition-property-accessor 'exn 'message) exn))
- #f)
- ;; Is there a cheaper single line operation that will check for existance of a table
- ;; and raise an exception ?
- (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
- db)
- (begin
- (debug:print-info 11 "open-test-db END (unsucessful)" work-area)
- #f)))
-
-;; find and open the testdat.db file for an existing test
-(define (db:open-test-db-by-test-id db test-id #!key (work-area #f))
- (let* ((test-path (if work-area
- work-area
- (cdb:remote-run db:test-get-rundir-from-test-id db test-id))))
- (debug:print 3 "TEST PATH: " test-path)
- (open-test-db test-path)))
-
-(define (db:testdb-initialize db)
- (debug:print 11 "db:testdb-initialize START")
- (for-each
- (lambda (sqlcmd)
- (sqlite3:execute db sqlcmd))
- (list "CREATE TABLE IF NOT EXISTS test_rundat (
- id INTEGER PRIMARY KEY,
- update_time TIMESTAMP,
- cpuload INTEGER DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- diskusage INTGER DEFAULT -1,
- run_duration INTEGER DEFAULT 0);"
- "CREATE TABLE IF NOT EXISTS test_data (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- category TEXT DEFAULT '',
- variable TEXT,
- value REAL,
- expected REAL,
- tol REAL,
- units TEXT,
- comment TEXT DEFAULT '',
- status TEXT DEFAULT 'n/a',
- type TEXT DEFAULT '',
- CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
- "CREATE TABLE IF NOT EXISTS test_steps (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- stepname TEXT,
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'n/a',
- event_time TIMESTAMP,
- comment TEXT DEFAULT '',
- logfile TEXT DEFAULT '',
- CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
- ;; test_meta can be used for handing commands to the test
- ;; e.g. KILLREQ
- ;; the ackstate is set to 1 once the command has been completed
- "CREATE TABLE IF NOT EXISTS test_meta (
- id INTEGER PRIMARY KEY,
- var TEXT,
- val TEXT,
- ackstate INTEGER DEFAULT 0,
- CONSTRAINT metadat_constraint UNIQUE (var));"))
- (debug:print 11 "db:testdb-initialize END"))
+ ;; Why use FULL here? This data is not that critical
+ ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ update_time TIMESTAMP,
+ cpuload INTEGER DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ diskusage INTGER DEFAULT -1,
+ run_duration INTEGER DEFAULT 0);")
+ db)
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
+ (db (sqlite3:open-database dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000)))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
@@ -373,13 +649,10 @@
(sqlite3:execute db (conc "PRAGMA synchronous = 0;"))))
db))
(define (db:log-local-event . loglst)
(let ((logline (apply conc loglst)))
- ;; (pwd (current-directory))
- ;; (cmdline (string-intersperse (argv) " "))
- ;; (pid (current-process-id)))
(db:log-event logline)))
(define (db:log-event logline)
(let ((db (open-logging-db)))
(sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
@@ -389,93 +662,12 @@
(current-process-id))
(sqlite3:finalize! db)
logline))
;;======================================================================
-;; TODO:
-;; put deltas into an assoc list with version numbers
-;; apply all from last to current
+;; D B U T I L S
;;======================================================================
-(define (patch-db db)
- (handle-exceptions
- exn
- (begin
- (print "Exception: " exn)
- (print "ERROR: Possible out of date schema, attempting to add table metadata...")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (if (not (db:get-var db "MEGATEST_VERSION"))
- (db:set-var db "MEGATEST_VERSION" 1.17)))
- (let ((mver (db:get-var db "MEGATEST_VERSION"))
- (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY,
- testname TEXT DEFAULT '',
- author TEXT DEFAULT '',
- owner TEXT DEFAULT '',
- description TEXT DEFAULT '',
- reviewed TIMESTAMP,
- iterated TEXT DEFAULT '',
- avg_runtime REAL,
- avg_disk REAL,
- tags TEXT DEFAULT '',
- CONSTRAINT test_meta_constraint UNIQUE (testname));"))
- (print "Current schema version: " mver " current megatest version: " megatest-version)
- (cond
- ((not mver)
- (print "Adding megatest-version to metadata") ;; Need to recreate the table
- (sqlite3:execute db "DROP TABLE IF EXISTS metadat;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (db:set-var db "MEGATEST_VERSION" 1.17)
- (patch-db))
- ((< mver 1.21)
- (sqlite3:execute db "DROP TABLE IF EXISTS metadat;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied
- (sqlite3:execute db test-meta-def)
- ;(for-each
- ; (lambda (stmt)
- ; (sqlite3:execute db stmt))
- ; (list
- ; "ALTER TABLE tests ADD COLUMN first_err TEXT;"
- ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;"
- ; ))
- (patch-db))
- ((< mver 1.24)
- (db:set-var db "MEGATEST_VERSION" 1.24)
- (sqlite3:execute db "DROP TABLE IF EXISTS test_data;")
- (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;")
- (sqlite3:execute db test-meta-def)
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- category TEXT DEFAULT '',
- variable TEXT,
- value REAL,
- expected REAL,
- tol REAL,
- units TEXT,
- comment TEXT DEFAULT '',
- status TEXT DEFAULT 'n/a',
- CONSTRAINT test_data UNIQUE (test_id,category,variable));")
- (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta")
- (patch-db))
- ((< mver 1.27)
- (db:set-var db "MEGATEST_VERSION" 1.27)
- (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';")
- (patch-db))
- ((< mver 1.29)
- (db:set-var db "MEGATEST_VERSION" 1.29)
- (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
- (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
- ((< mver 1.36)
- (db:set-var db "MEGATEST_VERSION" 1.36)
- (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
- ((< mver 1.37)
- (db:set-var db "MEGATEST_VERSION" 1.37)
- (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;"))
- ((< mver megatest-version)
- (db:set-var db "MEGATEST_VERSION" megatest-version))))))
;;======================================================================
;; M A I N T E N A N C E
;;======================================================================
@@ -482,74 +674,70 @@
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCED'));
-(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f))
+(define (db:find-and-mark-incomplete db run-id #!key (ovr-deadtime #f))
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
(deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
- 7200)) ;; two hours
- (run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls
+ 7200))) ;; two hours
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
- (for-each
- (lambda (run-id)
-
- ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
- ;;
- ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns.
- ;; The testdat.db file must be consulted.
- ;;
- ;; 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)
- (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?
- (begin
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
- (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 600 AND state IN ('RUNNING','REMOTEHOSTSTART');"
- run-id)
-
- ;; 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)
- (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?
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
- run-id))
- run-ids)
+
+ ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
+ ;;
+ ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns.
+ ;; The testdat.db file must be consulted.
+ ;;
+ ;; 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)
+ (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?
+ (begin
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+ (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
+ (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
+ db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 600 AND state IN ('RUNNING','REMOTEHOSTSTART');"
+ run-id)
+
+ ;; 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)
+ (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?
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
+ db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
+ run-id)
;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
;;
- (db:delay-if-busy)
+ ;; (db:delay-if-busy)
(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
- (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
- incompleted))
- (min-incompleted-ids (map car min-incompleted))
- (all-ids (append min-incompleted-ids (map car oldlaunched))))
+ (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
+ (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
+ incompleted))
+ (min-incompleted-ids (map car min-incompleted))
+ (all-ids (append min-incompleted-ids (map car oldlaunched))))
(if (> (length all-ids) 0)
(begin
(debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
(sqlite3:execute
db
@@ -575,12 +763,16 @@
;; b. If test dir gone, delete the test record
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
-(define (db:clean-up db)
- (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
+(define (db:clean-up dbstruct)
+
+ (debug:print 0 "ERROR: db clean up not ported yet")
+
+ (let* ((db (db:get-db dbstruct #f))
+ (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
;; delete all tests that belong to runs that are 'deleted'
@@ -608,25 +800,28 @@
(sqlite3:finalize! count-stmt)
(db:find-and-mark-incomplete db)
(sqlite3:execute db "VACUUM;")))
;;======================================================================
-;; meta get and set vars
+;; M E T A G E T A N D S E T V A R S
;;======================================================================
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
-(define (db:get-var db var)
- (debug:print-info 11 "db:get-var START " var)
+;;
+;; Operates on megatestdb
+;;
+(define (db:get-var dbstruct var)
(let* ((start-ms (current-milliseconds))
(throttle (let ((t (config-lookup *configdat* "setup" "throttle")))
(if t (string->number t) t)))
(res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
- db "SELECT val FROM metadat WHERE var=?;" var)
+ (db:get-db dbstruct #f)
+ "SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
;; scale by 10, average with current value.
@@ -635,74 +830,75 @@
2))
(if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
(begin
(debug:print-info 4 "launch throttle factor=" *global-delta*)
(set! *last-global-delta-printed* *global-delta*)))
- (debug:print-info 11 "db:get-var END " var " val=" res)
res))
-(define (db:set-var db var val)
- (debug:print-info 11 "db:set-var START " var " " val)
- (db:delay-if-busy)
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)
- (debug:print-info 11 "db:set-var END " var " " val))
-
-(define (db:del-var db var)
- (debug:print-info 11 "db:del-var START " var)
- (db:delay-if-busy)
- (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)
- (debug:print-info 11 "db:del-var END " var))
+(define (db:set-var dbstruct var val)
+ ;; (db:delay-if-busy)
+ (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))
+
+(define (db:del-var dbstruct var)
+ ;; (db:delay-if-busy)
+ (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" var))
;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
-(define (db:get-keys db)
+(define (db:get-keys dbstruct)
(if *db-keys* *db-keys*
(let ((res '()))
- (sqlite3:for-each-row
- (lambda (key)
- (set! res (cons key res)))
- db
- "SELECT fieldname FROM keys ORDER BY id DESC;")
+ (db:with-db dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (key)
+ (set! res (cons key res)))
+ (db:get-db dbstruct #f)
+ "SELECT fieldname FROM keys ORDER BY id DESC;")))
(set! *db-keys* res)
res)))
-;;
+;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
- (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field)
(if (null? header) #f
(let loop ((hed (car header))
(tal (cdr header))
(n 0))
(if (equal? hed field)
(vector-ref row n)
(if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))
+;; Accessors for the header/data structure
+;; get rows and header from
+(define (db:get-header vec)(vector-ref vec 0))
+(define (db:get-rows vec)(vector-ref vec 1))
+
;;======================================================================
;; R U N S
;;======================================================================
-(define (db:get-run-name-from-id db run-id)
+(define (db:get-run-name-from-id dbstruct run-id)
(let ((res #f))
(sqlite3:for-each-row
(lambda (runname)
(set! res runname))
- db
+ (db:get-db dbstruct #f)
"SELECT runname FROM runs WHERE id=?;"
run-id)
res))
-(define (db:get-run-key-val db run-id key)
+(define (db:get-run-key-val dbstruct run-id key)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
- db
+ (db:get-db dbstruct #f)
(conc "SELECT " key " FROM runs WHERE id=?;")
run-id)
res))
;; keys list to key1,key2,key3 ...
@@ -724,14 +920,16 @@
'("")
patts))
comparator)))
-;; register a test run with the db
-(define (db:register-run db keyvals runname state status user)
- (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user)
- (let* ((keys (map car keyvals))
+;; register a test run with the db, this accesses the main.db and does NOT
+;; use server api
+;;
+(define (db:register-run dbstruct keyvals runname state status user)
+ (let* ((db (db:get-db dbstruct #f))
+ (keys (map car keyvals))
(keystr (keys->keystr keys))
(comma (if (> (length keys) 0) "," ""))
(andstr (if (> (length keys) 0) " AND " ""))
(valslots (keys->valslots keys)) ;; ?,?,? ...
(allvals (append (list runname state status user) (map cadr keyvals)))
@@ -739,11 +937,11 @@
(key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
(debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
(debug:print 2 "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)
+ ;; (db:delay-if-busy)
(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)
(apply sqlite3:for-each-row
(lambda (id)
(set! res id))
@@ -750,121 +948,196 @@
db
(let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
;(debug:print 4 "qry: " qry)
qry)
qryvals)
- (db:delay-if-busy)
+ ;; (db:delay-if-busy)
(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 0 "ERROR: Called without all necessary keys")
#f))))
-
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
-(define (db:get-runs db runpatt count offset keypatts)
+(define (db:get-runs dbstruct runpatt count offset keypatts)
(let* ((res '())
- (keys (db:get-keys db))
+ (keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ",")))
+ (string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
- ;; Generate: " AND x LIKE 'keypatt' ..."
- (if (null? keypatts) ""
- (conc " AND "
+ ;; Generate: " AND x LIKE 'keypatt' ..."
+ (if (null? keypatts) ""
+ (conc " AND "
(string-join
(map (lambda (keypatt)
(let ((key (car keypatt))
(patt (cadr keypatt)))
(db:patt->like key patt)))
keypatts)
" AND ")))
- " AND state != 'deleted' ORDER BY event_time DESC "
- (if (number? count)
- (conc " LIMIT " count)
- "")
- (if (number? offset)
- (conc " OFFSET " offset)
- ""))))
+ " AND state != 'deleted' ORDER BY event_time DESC "
+ (if (number? count)
+ (conc " LIMIT " count)
+ "")
+ (if (number? offset)
+ (conc " OFFSET " offset)
+ ""))))
(debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
- (sqlite3:for-each-row
- (lambda (a . x)
- (set! res (cons (apply vector a x) res)))
- db
- qrystr
- )
+ (db:with-db dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . x)
+ (set! res (cons (apply vector a x) res)))
+ db
+ qrystr
+ )))
(debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(vector header res)))
+;; db:get-runs-by-patt
+;; get runs by list of criteria
+;; register a test run with the db
+;;
+;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+;; to extract info from the structure returned
+;;
+;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames
+;;
+(define (db:get-run-ids-matching dbstruct keynames target res)
+;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
+ (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
+ (keystr (car tmp))
+ (header (cadr tmp))
+ (res '())
+ (key-patt "")
+ (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
+ (qry-str #f)
+ (keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
+ (for-each (lambda (keyval)
+ (let* ((key (car keyval))
+ (patt (cadr keyval))
+ (fulkey (conc ":" key))
+ (wildtype (if (substring-index "%" patt) "like" "glob")))
+ (if patt
+ (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
+ (begin
+ (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
+ (exit 6)))))
+ keyvals)
+ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time "
+ (if limit (conc " LIMIT " limit) "")
+ (if offset (conc " OFFSET " offset) "")
+ ";"))
+ (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
+ (db:with-db dbstruct #f #f ;; reads db, does not write to it.
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . r)
+ (set! res (cons (list->vector (cons a r)) res)))
+ (db:get-db dbstruct #f)
+ qry-str
+ runnamepatt)))
+ (vector header res)))
+
;; Get all targets from the db
;;
-(define (db:get-targets db)
+(define (db:get-targets dbstruct)
(let* ((res '())
- (keys (db:get-keys db))
+ (keys (db:get-keys dbstruct))
(header keys) ;; (map key:get-fieldname keys))
(keystr (keys->keystr keys))
- (qrystr (conc "SELECT " keystr " FROM runs;"))
+ (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
(seen (make-hash-table)))
(sqlite3:for-each-row
(lambda (a . x)
(let ((targ (cons a x)))
(if (not (hash-table-ref/default seen targ #f))
(begin
(hash-table-set! seen targ #t)
(set! res (cons (apply vector targ) res))))))
- db
+ (db:get-db dbstruct #f)
qrystr)
(debug:print-info 11 "db:get-targets END qrystr: " qrystr )
(vector header res)))
;; just get count of runs
-(define (db:get-num-runs db runpatt)
+(define (db:get-num-runs dbstruct runpatt)
(let ((numruns 0))
(debug:print-info 11 "db:get-num-runs START " runpatt)
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
- db
+ (db:get-db dbstruct #f)
"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
(debug:print-info 11 "db:get-num-runs END " runpatt)
numruns))
+
+(define (db:get-all-run-ids dbstruct)
+ (let ((run-ids '()))
+ (sqlite3:for-each-row
+ (lambda (run-id)
+ (set! run-ids (cons run-id run-ids)))
+ (db:get-db dbstruct #f)
+ "SELECT id FROM runs WHERE state != 'deleted';")
+ (reverse run-ids)))
;; get some basic run stats
;;
;; ( (runname (( state count ) ... ))
;; ( ...
-(define (db:get-run-stats db)
+(define (db:get-run-stats dbstruct)
(let ((totals (make-hash-table))
- (res '()))
+ (curr (make-hash-table))
+ (res '())
+ (runs-info '()))
+ ;; First get all the runname/run-ids
(sqlite3:for-each-row
- (lambda (runname state count)
- (let* ((stateparts (string-split state "|"))
- (newstate (conc (car stateparts) "\n" (cadr stateparts))))
- (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count))
- (set! res (cons (list runname newstate count) res))))
- db
- "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" )
- ;; (set! res (reverse res))
+ (lambda (run-id runname)
+ (set! runs-info (cons (list run-id runname) runs-info)))
+ (db:get-db dbstruct #f)
+ "SELECT id,runname FROM runs WHERE state != 'deleted';")
+ ;; for each run get stats data
+ (for-each
+ (lambda (run-info)
+ ;; get the net state/status counts for this run
+ (let ((run-id (car run-info))
+ (run-name (cadr run-info)))
+ (sqlite3:for-each-row
+ (lambda (state status count)
+ (let ((netstate (if (equal? state "COMPLETED") status state)))
+ (if (string? netstate)
+ (begin
+ (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
+ (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count))))))
+ (db:get-db dbstruct run-id)
+ "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;")
+ ;; add the per run counts to res
+ (for-each (lambda (state)
+ (set! res (cons (list run-name state (hash-table-ref curr state)) res)))
+ (sort (hash-table-keys curr) string>=))
+ (set! curr (make-hash-table))))
+ runs-info)
(for-each (lambda (state)
(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
(sort (hash-table-keys totals) string>=))
res))
;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
-;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
+;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; to extract info from the structure returned
;;
-(define (db:get-runs-by-patt db keys runnamepatt targpatt offset limit) ;; test-name)
+(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt "")
@@ -880,85 +1153,79 @@
(set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
(begin
(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
(exit 6)))))
keyvals)
- (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time"
+ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time "
(if limit (conc " LIMIT " limit) "")
(if offset (conc " OFFSET " offset) "")
";"))
(debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
- (sqlite3:for-each-row
- (lambda (a . r)
- (set! res (cons (list->vector (cons a r)) res)))
- db
- qry-str
- runnamepatt)
+ (db:with-db dbstruct #f #f ;; reads db, does not write to it.
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . r)
+ (set! res (cons (list->vector (cons a r)) res)))
+ (db:get-db dbstruct #f)
+ qry-str
+ runnamepatt)))
(vector header res)))
-;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
-(define (db:get-run-info db run-id)
+;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+(define (db:get-run-info dbstruct run-id)
;;(if (hash-table-ref/default *run-info-cache* run-id #f)
;; (hash-table-ref *run-info-cache* run-id)
- (let* ((res #f)
- (keys (db:get-keys db))
+ (let* ((res (vector #f #f #f #f))
+ (keys (db:get-keys dbstruct))
(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 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
- db
+ (db:get-db dbstruct #f)
(conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
run-id)
(debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(let ((finalres (vector header res)))
;; (hash-table-set! *run-info-cache* run-id finalres)
finalres)))
-(define (db:set-comment-for-run db run-id comment)
- (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment)
- (db:delay-if-busy)
- (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)
- (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment))
+(define (db:set-comment-for-run dbstruct run-id comment)
+ ;; (db:delay-if-busy)
+ (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
+ run-id))
;; does not (obviously!) removed dependent data. But why not!!?
-(define (db:delete-run db run-id)
- (common:clear-caches) ;; don't trust caches after doing any deletion
+(define (db:delete-run dbstruct run-id)
;; First set any related tests to DELETED
- (db:delay-if-busy)
- (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;"))
- (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;")))
- (sqlite3:with-transaction
- db (lambda ()
- (sqlite3:execute stmt1 run-id)
- (sqlite3:execute stmt2 run-id)))
- (sqlite3:finalize! stmt1)
- (sqlite3:finalize! stmt2)))
-;; (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id))
-
-(define (db:update-run-event_time db run-id)
- (debug:print-info 11 "db:update-run-event_time START run-id: " run-id)
- (db:delay-if-busy)
- (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)
- (debug:print-info 11 "db:update-run-event_time END run-id: " run-id))
-
-(define (db:lock/unlock-run db run-id lock unlock user)
+ (let ((db (db:get-db dbstruct run-id)))
+ ;; (db:delay-if-busy)
+ (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';")
+ (sqlite3:execute db "DELETE FROM test_steps;")
+ (sqlite3:execute db "DELETE FROM test_data;")
+ (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))
+
+(define (db:update-run-event_time dbstruct run-id)
+ ;; (db:delay-if-busy)
+ (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))
+
+(define (db:lock/unlock-run dbstruct run-id lock unlock user)
(let ((newlockval (if lock "locked"
(if unlock
"unlocked"
"locked")))) ;; semi-failsafe
- (db:delay-if-busy)
- (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
- (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
+ (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
+ ;; (db:delay-if-busy)
+ (sqlite3:execute (db:get-db dbstruct #f) "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
user (conc newlockval " " run-id))
(debug:print-info 1 "" newlockval " run number " run-id)))
(define (db:set-run-status db run-id status #!key (msg #f))
- (db:delay-if-busy)
+ ;; (db:delay-if-busy)
(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 db run-id)
@@ -969,144 +1236,146 @@
db
"SELECT status FROM runs WHERE id=?;"
run-id)
res))
-(define (db:get-run-ids db)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id)
- (set! res (cons id res)))
- db
- "SELECT id FROM runs;")))
-
;;======================================================================
;; K E Y S
;;======================================================================
;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
-(define (db:get-key-val-pairs db run-id)
- (let* ((keys (db:get-keys db))
+(define (db:get-key-val-pairs dbstruct run-id)
+ (let* ((keys (db:get-keys dbstruct))
(res '()))
- (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
;; (debug:print 0 "qry: " qry)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons (list key key-val) res)))
- db qry run-id)))
+ (db:get-db dbstruct #f) qry run-id)))
keys)
- (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id)
(reverse res)))
;; get key vals for a given run-id
-(define (db:get-key-vals db run-id)
- (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f)))
- (if mykeyvals
- mykeyvals
- (let* ((keys (db:get-keys db))
- (res '()))
- (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id)
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- ;; (debug:print 0 "qry: " qry)
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons key-val res)))
- db qry run-id)))
- keys)
- (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id)
- (let ((final-res (reverse res)))
- (hash-table-set! *keyvals* run-id final-res)
- final-res)))))
+(define (db:get-key-vals dbstruct run-id)
+ (let* ((keys (db:get-keys dbstruct))
+ (res '()))
+ (for-each
+ (lambda (key)
+ (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+ (sqlite3:for-each-row
+ (lambda (key-val)
+ (set! res (cons key-val res)))
+ (db:get-db dbstruct #f) qry run-id)))
+ keys)
+ (let ((final-res (reverse res)))
+ (hash-table-set! *keyvals* run-id final-res)
+ final-res)))
;; The target is keyval1/keyval2..., cached in *target* as it is used often
-(define (db:get-target db run-id)
- (let ((mytarg (hash-table-ref/default *target* run-id #f)))
- (if mytarg
- mytarg
- (let* ((keyvals (db:get-key-vals db run-id))
- (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
- (hash-table-set! *target* run-id thekey)
- thekey))))
+(define (db:get-target dbstruct run-id)
+ (let* ((keyvals (db:get-key-vals dbstruct run-id))
+ (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
+ thekey))
+
+;; Get run-ids for runs with same target but different runnames and NOT run-id
+;;
+(define (db:get-prev-run-ids dbstruct run-id)
+ (let* ((keyvals (rmt:get-key-val-pairs run-id))
+ (kvalues (map cadr keyvals))
+ (keys (rmt:get-keys))
+ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
+ (let ((prev-run-ids '()))
+ (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
+ (lambda (db)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id)))))
+ prev-run-ids)))
;;======================================================================
;; T E S T S
;;======================================================================
;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
-(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order
- #!key
- (qryvals #f))
- (let* ((qryvalstr (case qryvals
- ((shortlist) "id,run_id,testname,item_path,state,status")
- ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
- (else qryvals)))
- (res '())
- ;; if states or statuses are null then assume match all when not-in is false
- (states-qry (if (null? states)
- #f
- (conc " state "
- (if not-in
- " NOT IN ('"
- " IN ('")
- (string-intersperse states "','")
- "')")))
- (statuses-qry (if (null? statuses)
- #f
- (conc " status "
- (if not-in
- " NOT IN ('"
- " IN ('")
- (string-intersperse statuses "','")
- "')")))
- (states-statuses-qry
- (cond
- ((and states-qry statuses-qry)
- (conc " AND ( " states-qry " AND " statuses-qry " ) "))
- (states-qry
- (conc " AND " states-qry))
- (statuses-qry
- (conc " AND " statuses-qry))
- (else "")))
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT " qryvalstr
- " FROM tests WHERE run_id=? AND state != 'DELETED' "
- states-statuses-qry
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- (case sort-by
- ((rundir) " ORDER BY length(rundir) ")
- ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
- ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
- ((event_time) " ORDER BY event_time ")
- (else (if (string? sort-by)
- (conc " ORDER BY " sort-by)
- "")))
- (if sort-order sort-order "")
- (if limit (conc " LIMIT " limit) "")
- (if offset (conc " OFFSET " offset) "")
- ";"
- )))
- (debug:print-info 8 "db:get-tests-for-run qry=" qry)
- (sqlite3:for-each-row
- (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
- (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
- db
- qry
- run-id
- )
- (case qryvals
- ((shortlist)(map db:test-short-record->norm res))
- ((#f) res)
- (else res))))
+(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
+ (if (not (number? run-id))
+ (begin
+ (debug:print 0 "ERROR: call to db:get-tests-for-run with bad run-id=" run-id)
+ (print-call-chain)
+ '())
+ (let* ((qryvalstr (case qryvals
+ ((shortlist) "id,run_id,testname,item_path,state,status")
+ ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
+ (else qryvals)))
+ (res '())
+ ;; if states or statuses are null then assume match all when not-in is false
+ (states-qry (if (null? states)
+ #f
+ (conc " state "
+ (if not-in
+ " NOT IN ('"
+ " IN ('")
+ (string-intersperse states "','")
+ "')")))
+ (statuses-qry (if (null? statuses)
+ #f
+ (conc " status "
+ (if not-in
+ " NOT IN ('"
+ " IN ('")
+ (string-intersperse statuses "','")
+ "')")))
+ (states-statuses-qry
+ (cond
+ ((and states-qry statuses-qry)
+ (conc " AND ( " states-qry " AND " statuses-qry " ) "))
+ (states-qry
+ (conc " AND " states-qry))
+ (statuses-qry
+ (conc " AND " statuses-qry))
+ (else "")))
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT " qryvalstr
+ " FROM tests WHERE run_id=? AND state != 'DELETED' "
+ states-statuses-qry
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+ (case sort-by
+ ((rundir) " ORDER BY length(rundir) ")
+ ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
+ ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
+ ((event_time) " ORDER BY event_time ")
+ (else (if (string? sort-by)
+ (conc " ORDER BY " sort-by " ")
+ " ")))
+ (if sort-order sort-order " ")
+ (if limit (conc " LIMIT " limit) " ")
+ (if offset (conc " OFFSET " offset) " ")
+ ";"
+ )))
+ (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
+ (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
+ db
+ qry
+ run-id
+ )))
+ (case qryvals
+ ((shortlist)(map db:test-short-record->norm res))
+ ((#f) res)
+ (else res)))))
(define (db:test-short-record->norm inrec)
;; "id,run_id,testname,item_path,state,status"
;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(vector (vector-ref inrec 0) ;; id
@@ -1117,473 +1386,436 @@
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
-(define (db:get-tests-for-run-state-status db run-id testpatt)
- (let ((res '())
- (tests-match-qry (tests:match->sqlqry testpatt)))
- (sqlite3:for-each-row
- (lambda (id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
- db
- (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))
- run-id)
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
+ (let* ((res '())
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
+ (debug:print-info 8 "db:get-tests-for-run qry=" qry)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
+ db
+ qry
+ run-id)))
res))
-(define (db:get-testinfo-state-status db test-id)
+(define (db:get-testinfo-state-status dbstruct run-id test-id)
(let ((res #f))
- (sqlite3:for-each-row
- (lambda (run-id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
- db
- "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;"
- test-id)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (run-id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
+ db
+ "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;"
+ test-id)))
res))
;; get a useful subset of the tests data (used in dashboard
;; use db:mintests-get-{id ,run_id,testname ...}
-(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in)
- (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
-
-
-;; NB // This is get tests for "runs" (note the plural!!)
-;;
-;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
-;; i.e. these lists define what to NOT show.
-;; states and statuses are required to be lists, empty is ok
-;; not-in #t = above behaviour, #f = must match
-;; run-ids is a list of run-ids or a single number or #f for all runs
-(define (db:get-tests-for-runs db run-ids testpatt states statuses
- #!key (not-in #t)
- (sort-by #f)
- (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time
- (let* ((res '())
- ;; if states or statuses are null then assume match all when not-in is false
- (states-qry (if (null? states)
- #f
- (conc " state "
- (if not-in "NOT" "")
- " IN ('"
- (string-intersperse states "','")
- "')")))
- (statuses-qry (if (null? statuses)
- #f
- (conc " status "
- (if not-in "NOT" "")
- " IN ('"
- (string-intersperse statuses "','")
- "')")))
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT " qryvals
- " FROM tests WHERE state != 'DELETED' "
- (if run-ids
- (if (list? run-ids)
- (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ")
- (conc "AND run_id=" run-ids " "))
- " ") ;; #f => run-ids don't filter on run-ids
- (if states-qry (conc " AND " states-qry) "")
- (if statuses-qry (conc " AND " statuses-qry) "")
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- (case sort-by
- ((rundir) " ORDER BY length(rundir) DESC;")
- ((event_time) " ORDER BY event_time ASC;")
- (else ";"))
- )))
- (debug:print-info 8 "db:get-tests-for-runs qry=" qry)
- (sqlite3:for-each-row
- (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
- (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
- db
- qry
- )
+(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in)
+ (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
+
+(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
+ ;; (db:delay-if-busy)
+ (let ((res '()))
+ (for-each
+ (lambda (run-id)
+ (set! res (append
+ res
+ (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals))))
+ (if run-ids
+ run-ids
+ (db:get-all-run-ids dbstruct)))
res))
-;; this one is a bit broken BUG FIXME
-(define (db:delete-test-step-records db test-id #!key (work-area #f))
- ;; Breaking it into two queries for better file access interleaving
- (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- ;; test db's can go away - must check every time
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:execute tdb "DELETE FROM test_steps;")
- (sqlite3:execute tdb "DELETE FROM test_data;")
- (sqlite3:finalize! tdb)))))
-
-;;
-(define (db:delete-test-records db tdb test-id #!key (force #f))
- (common:clear-caches)
- (db:delay-if-busy)
- (if tdb
- (begin
- (sqlite3:execute tdb "DELETE FROM test_steps;")
- (sqlite3:execute tdb "DELETE FROM test_data;")))
- ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id))
- (if db
- (begin
- (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
- (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id)
- (if force
- (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)
- (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))))
-
-(define (db:delete-tests-for-run db run-id)
- (common:clear-caches)
- (db:delay-if-busy)
- (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))
-
-(define (db:delete-old-deleted-test-records db)
- (common:clear-caches)
- (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
- (db:delay-if-busy)
- (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time;" targtime)))
+;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
+;;
+
+(define (db:delete-test-records dbstruct run-id test-id)
+ (let ((db (db:get-db dbstruct run-id)))
+ (db:general-call db 'delete-test-step-records (list test-id))
+ ;; (db:delay-if-busy)
+ (db:general-call db '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-tests-for-run dbdbstruct run-id)
+ (let ((db (db:get-db dbstruct run-id)))
+ (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-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)
+ (sqlite3:execute (db:get-db dbstruct run-id) "DELETE FROM tests WHERE state='DELETED' AND event_time;" targtime))
+ run-ids)))
;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
-(define (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)
+(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
(for-each (lambda (testname)
(let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
(if currstate (conc "state='" currstate "' AND ") "")
(if currstatus (conc "status='" currstatus "' AND ") "")
" run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
;;(debug:print 0 "QRY: " qry)
- (db:delay-if-busy)
- (sqlite3:execute db qry run-id newstate newstatus testname testname)))
- testnames))
-
-(define (cdb:delete-tests-in-state serverdat run-id state)
- (common:clear-caches)
- (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state))
-
-(define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree)
- (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id))
-
-(define (cdb:tests-update-run-duration serverdat test-id minutes)
- (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id))
-
-(define (cdb:tests-update-uname-host serverdat test-id uname hostname)
- (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id))
-
-;; speed up for common cases with a little logic
-;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
-;;
-(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
- (db:delay-if-busy)
- (cond
- ((and newstate newstatus newcomment)
- (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id))
- ((and newstate newstatus)
- (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
- (else
- (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
- (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 test-id))))
- (mt:process-triggers test-id newstate newstatus))
-
-;; Never used, but should be?
-(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
- (db:delay-if-busy)
- (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
- state status run-id test-name item-path))
-
-(define (db:get-count-tests-running db)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
- res))
-
-(define (db:get-count-tests-running-for-run-id db run-id)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count)) ;; select * from tests where run_id=1 and uname = 'n/a' and item_path='';
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id)
- res))
-
-(define (db:get-running-stats db)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (state count)
- (set! res (cons (list state count) res)))
- db
- "SELECT state,count(id) FROM tests GROUP BY state ORDER BY id DESC;")
- res))
-
-(define (db:get-count-tests-running-in-jobgroup db jobgroup)
- (if (not jobgroup)
- 0 ;;
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART')
- AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?)
- AND NOT (uname = 'n/a' AND item_path = '');"
- jobgroup)
- res)))
-
-;; done with run when:
-;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
-(define (db:estimated-tests-remaining db run-id)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db ;; NB// KILLREQ means the jobs is still probably running
- "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;" run-id)
- res))
-
-;; map run-id, testname item-path to test-id
-(define (db:get-test-id-cached db run-id testname item-path)
- (let* ((test-key (conc run-id "-" testname "-" item-path))
- (res (hash-table-ref/default *test-ids* test-key #f)))
- (if res
- res
- (begin
- (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 )
- (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))
- db
- "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
- run-id testname item-path)
- (hash-table-set! *test-ids* test-key res)
- res))))
-
-;; map run-id, testname item-path to test-id
-(define (db:get-test-id-not-cached db run-id testname item-path)
- (let* ((res #f))
- (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 )
- (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))
- db
- "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
- run-id testname item-path)
- res))
-
-(define db:get-test-id db:get-test-id-not-cached)
-
-;; given a test-info record, patch in the latest data from the testdat.db file
-;; found in the test run directory
-;;
-;; NOT USED
-;;
-(define (db:patch-tdb-data-into-test-info db test-id res #!key (work-area #f))
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- ;; get state and status from megatest.db in real time
- ;; other fields that perhaps should be updated:
- ;; fail_count
- ;; pass_count
- ;; final_logf
- (sqlite3:for-each-row
- (lambda (state status final_logf)
- (db:test-set-state! res state)
- (db:test-set-status! res status)
- (db:test-set-final_logf! res final_logf))
- db
- "SELECT state,status,final_logf FROM tests WHERE id=?;"
- test-id)
- (if tdb
- (begin
- (sqlite3:for-each-row
- (lambda (update_time cpuload disk_free run_duration)
- (db:test-set-cpuload! res cpuload)
- (db:test-set-diskfree! res disk_free)
- (db:test-set-run_duration! res run_duration))
- tdb
- "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY id DESC LIMIT 1;")
- (sqlite3:finalize! tdb))
- ;; if the test db is not found what to do?
- ;; 1. set state to DELETED
- ;; 2. set status to n/a
- (begin
- (db:test-set-state! res "NOT_STARTED")
- (db:test-set-status! res "n/a")))))
-
-(define *last-test-cache-delete* (current-seconds))
-
-(define (db:clean-all-caches)
- (set! *test-info* (make-hash-table))
- (set! *test-id-cache* (make-hash-table)))
-
-;; Use db:test-get* to access
-;;
-;; Get test data using test_id
-(define (db:get-test-info-by-id db test-id)
- (if (not test-id)
- (begin
- (debug:print-info 4 "db:get-test-info-by-id called with test-id=" test-id)
- #f)
- (let ((res #f))
- (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)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
- (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)))
- db
- "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;"
- test-id)
- res)))
-
-;; Use db:test-get* to access
-;;
-;; Get test data using test_ids
-(define (db:get-test-info-by-ids db test-ids)
- (if (null? test-ids)
- (begin
- (debug:print-info 4 "db:get-test-info-by-ids called with test-ids=" test-ids)
- '())
- (let ((res '()))
- (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)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
- (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
- res)))
- db
- (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id in ("
- (string-intersperse (map conc test-ids) ",") ");"))
- res)))
-
-(define (db:get-test-info db run-id testname item-path)
- (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path)))
-
-(define (db:test-set-comment db test-id comment)
- (db:delay-if-busy)
- (sqlite3:execute
- db
- "UPDATE tests SET comment=? WHERE id=?;"
- comment test-id))
-
-(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir)
- (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))
-
-(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir)
- (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id))
-
-(define (db:test-get-rundir-from-test-id db test-id)
- (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f)))
- ;; (if res
- ;; res
- ;; (begin
- (sqlite3:for-each-row
- (lambda (tpath)
- (set! res tpath))
- db
- "SELECT rundir FROM tests WHERE id=?;"
- test-id)
- ;; (hash-table-set! *test-paths* test-id res)
- res)) ;; ))
-
-(define (cdb:test-set-log! serverdat test-id logf)
- (if (string? logf)(cdb:client-call serverdat 'test-set-log #f *default-numtries* logf test-id)))
+ ;; (db:delay-if-busy)
+ (sqlite3:execute (db:get-db dbstruct run-id) qry run-id newstate newstatus testname testname)))
+ testnames))
+
+;; speed up for common cases with a little logic
+;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
+;;
+(define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment)
+ ;; (db:delay-if-busy)
+ (let ((db (db:get-db dbstruct run-id)))
+ (cond
+ ((and newstate newstatus newcomment)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
+ test-id))
+ ((and newstate newstatus)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
+ (else
+ (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
+ (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)))
+
+;; Never used, but should be?
+(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
+ ;; (db:delay-if-busy)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
+ state status run-id test-name item-path))
+
+;; NEW BEHAVIOR: Count tests running in only one run!
+;;
+(define (db:get-count-tests-running dbstruct run-id)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ (db:get-db dbstruct run-id)
+ ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
+ ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"
+ run-id) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
+ res))
+
+;; NEW BEHAVIOR: Look only at single run with run-id
+;;
+;; (define (db:get-running-stats dbstruct run-id)
+(define (db:get-count-tests-running-for-run-id dbstruct run-id)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count)) ;; select * from tests where run_id=1 and uname = 'n/a' and item_path='';
+ (db:get-db dbstruct run-id)
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id)
+ res))
+
+(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
+ (if (not jobgroup)
+ 0 ;;
+ (let ((res 0)
+ (testnames '()))
+ ;; get the testnames
+ (sqlite3:for-each-row
+ (lambda (testname)
+ (set! testnames (cons testname testnames)))
+ (db:get-db dbstruct #f)
+ "SELECT testname FROM test_meta WHERE jobgroup=?"
+ jobgroup)
+ ;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
+ (if (not (null? testnames))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
+ (string-intersperse testnames "','")
+ "');")))
+ ;; DEBUG FIXME - need to merge this v.155 query correctly
+ ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?)
+ ;; AND NOT (uname = 'n/a' AND item_path = '');"
+ res)))
+
+;; done with run when:
+;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
+(define (db:estimated-tests-remaining dbstruct run-id)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ (db:get-db dbstruct run-id) ;; NB// KILLREQ means the jobs is still probably running
+ "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');")
+ res))
+
+;; map run-id, testname item-path to test-id
+(define (db:get-test-id dbstruct run-id testname item-path)
+ (let* ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (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 )
+ (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))
+ (db:get-db dbstruct run-id)
+ "SELECT id FROM tests WHERE testname=? AND item_path=?;"
+ testname item-path)
+ res))
+
+(define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time"
+ "host" "cpuload" "diskfree" "uname" "rundir" "item_path"
+ "run_duration" "final_logf" "comment" "shortdir"))
+
+(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
+
+;; NOTE: Use db:test-get* to access records
+;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
+(define (db:get-all-tests-info-by-run-id dbstruct run-id)
+ (let ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (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)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ (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)
+ res)))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
+ run-id)
+ res))
+
+(define (db:replace-test-records dbstruct run-id testrecs)
+ (db:with-db dbstruct run-id #t
+ (lambda (db)
+ (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
+ (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");"))
+ (qry (sqlite3:prepare db qrystr)))
+ ;; (debug:print 8 "INFO: replace-test-records, qrystr=" qrystr)
+ (for-each
+ (lambda (rec)
+ (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ", "))
+ (apply sqlite3:execute qry (vector->list rec)))
+ testrecs)
+ (sqlite3:finalize! qry)))))
+
+
+;; Get test data using test_id
+(define (db:get-test-info-by-id dbstruct run-id test-id)
+ (let ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id)))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
+ test-id)
+ res))
+
+;; Use db:test-get* to access
+;; Get test data using test_ids. NB// Only works within a single run!!
+;;
+(define (db:get-test-info-by-ids dbstruct run-id test-ids)
+ (let ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id)
+ res)))
+ (db:get-db dbstruct run-id)
+ (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)
+ (let ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (apply vector a b)))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;")
+ test-name item-path)
+ res))
+
+(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
+ ;; (db:delay-if-busy)
+ (let ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (tpath)
+ (set! res tpath))
+ (db:get-db dbstruct run-id)
+ "SELECT rundir FROM tests WHERE id=?;"
+ test-id)
+ res))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
+ (let ((db (db:get-db dbstruct run-id)))
+ (sqlite3:execute
+ db
+ "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
+ test-id teststep-name state-in status-in (current-seconds)
+ ;; (sdb:qry 'getid
+ (if comment comment "") ;; )
+ ;; (sdb:qry 'getid
+ (if logfile logfile "")))) ;; )
+
+;; db-get-test-steps-for-run
+(define (db:get-steps-for-test dbstruct run-id test-id)
+ (let* ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile)
+ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-id)
+ (reverse res)))
+
+(define (db:get-steps-data dbstruct run-id test-id)
+ (let ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile)
+ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-id)
+ (reverse res)))
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+
+;; WARNING: Do NOT call this for the parent test on an iterated test
+;; Roll up test_data pass/fail results
+;; look at the test_data status field,
+;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
+;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
+(define (db:test-data-rollup dbstruct run-id test-id status)
+ (let ((db (db:get-db dbstruct run-id))
+ (fail-count 0)
+ (pass-count 0))
+ (sqlite3:for-each-row
+ (lambda (fcount pcount)
+ (set! fail-count fcount)
+ (set! pass-count pcount))
+ db
+ "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
+ (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
+ test-id test-id)
+ ;; Now rollup the counts to the central megatest.db
+ (db:general-call db 'pass-fail-counts (list pass-count fail-count test-id))
+ ;; if the test is not FAIL then set status based on the fail and pass counts.
+ (db:general-call db 'test_data-pf-rollup (list test-id test-id test-id test-id))))
+
+(define (db:csv->test-data dbstruct run-id test-id csvdata)
+ (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
+ (let ((db (db:get-db dbstruct run-id))
+ (csvlist (csv->list (make-csv-reader
+ (open-input-string csvdata)
+ '((strip-leading-whitespace? #t)
+ (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
+ (for-each
+ (lambda (csvrow)
+ (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
+ (category (list-ref padded-row 0))
+ (variable (list-ref padded-row 1))
+ (value (any->number-if-possible (list-ref padded-row 2)))
+ (expected (any->number-if-possible (list-ref padded-row 3)))
+ (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
+ (units (list-ref padded-row 5))
+ (comment (list-ref padded-row 6))
+ (status (let ((s (list-ref padded-row 7)))
+ (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
+ (string-match (regexp "^n/a$") s)))
+ #f
+ s))) ;; if specified on the input then use, else calculate
+ (type (list-ref padded-row 8)))
+ ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
+ (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
+
+ (if (and (or (not expected)(equal? expected ""))
+ (or (not tol) (equal? expected ""))
+ (or (not units) (equal? expected "")))
+ (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable)))
+ (set! expected new-expected)
+ (set! tol new-tol)
+ (set! units new-units)))
+
+ (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ ;; calculate status if NOT specified
+ (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
+ (if (number? tol) ;; if tol is a number then we do the standard comparison
+ (let* ((max-val (+ expected tol))
+ (min-val (- expected tol))
+ (result (and (>= value min-val)(<= value max-val))))
+ (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
+ (set! status (if result "pass" "fail")))
+ (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
+ (case (string->symbol tol) ;; tol should be >, <, >=, <=
+ ((>) (if (> value expected) "pass" "fail"))
+ ((<) (if (< value expected) "pass" "fail"))
+ ((>=) (if (>= value expected) "pass" "fail"))
+ ((<=) (if (<= value expected) "pass" "fail"))
+ (else (conc "ERROR: bad tol comparator " tol))))))
+ (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ (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)))
;;======================================================================
;; Misc. test related queries
;;======================================================================
-;; MUST BE CALLED local!
-(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
- ;; BUG: Move the values derived from args to parameters and push to megatest.scm
- (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
- (statepatt (or (args:get-arg "-state") (args:get-arg ":state") "%"))
- (statuspatt (or (args:get-arg "-status") (args:get-arg ":status") "%"))
- (runname (or (args:get-arg "-runname") (args:get-arg ":runname") "%"))
- (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target-new db keynames target res
- testpatt: testpatt
- statepatt: statepatt
- statuspatt: statuspatt
- runname: runname)))
- (if fnamepatt
- (apply append
- (map (lambda (p)
- (if (directory-exists? p)
- (glob (conc p "/" fnamepatt))
- '()))
- paths-from-db))
- paths-from-db)))
-
-(define (db:test-get-paths-matching-keynames-target db keynames target res
- #!key
- (testpatt "%")
- (statepatt "%")
- (statuspatt "%")
- (runname "%"))
- (let* ((keystr (string-intersperse
- (map (lambda (key val)
- (conc "r." key " like '" val "'"))
- keynames
- (string-split target "/"))
- " AND "))
- (testqry (tests:match->sqlqry testpatt))
- (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
- keystr " AND r.runname LIKE '" runname "' AND " testqry
- " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt
- "' ORDER BY t.event_time ASC;")))
- (sqlite3:for-each-row
- (lambda (p)
- (set! res (cons p res)))
- db
- qrystr)
- res))
-
-(define (db:test-get-paths-matching-keynames-target-new db keynames target res
- #!key
- (testpatt "%")
- (statepatt "%")
- (statuspatt "%")
- (runname "%"))
+(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
(let* ((row-ids '())
(keystr (string-intersperse
(map (lambda (key val)
(conc key " like '" val "'"))
keynames
(string-split target "/"))
" AND "))
- (testqry (tests:match->sqlqry testpatt))
- (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))
- (tstsqry (sqlite3:prepare db (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))))
+ ;; (testqry (tests:match->sqlqry testpatt))
+ (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
+ ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
(sqlite3:for-each-row
(lambda (rid)
(set! row-ids (cons rid row-ids)))
runsqry)
- (for-each (lambda (rid)
- (sqlite3:for-each-row
- (lambda (p)
- (set! res (cons p res)))
- tstsqry rid))
- row-ids)
- (sqlite3:finalize! tstsqry)
(sqlite3:finalize! runsqry)
- res))
-
-;; look through tests from matching runs for a file
-(define (db:test-get-first-path-matching db keynames target fname)
- ;; [refpaths] is the section where references to other megatest databases are stored
- (let ((mt-paths (configf:get-section "refpaths"))
- (res (db:test-get-paths-matching db keynames target fname)))
- (let loop ((pathdat (if (null? paths) #f (car mt-paths)))
- (tal (if (null? paths) '()(cdr mt-paths))))
- (if (not (null? res))
- (car res) ;; return first found
- (if path
- (let* ((db (open-db path: (cadr pathdat)))
- (newres (db:test-get-paths-matching db keynames target fname)))
- (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat))
- (sqlite3:finalize! db)
- (if (not (null? newres))
- (car newres)
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal))))))))))
+ row-ids))
+
+(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
+ (let* ((testqry (tests:match->sqlqry testpatt))
+ (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
+ (sqlite3:for-each-row
+ (lambda (p)
+ (set! res (cons p res)))
+ (db:get-db dbstruct run-id)
+ tstsqry)
+ res))
(define (db:test-toplevel-num-items db run-id testname)
(let ((res 0))
(sqlite3:for-each-row
(lambda (num-items)
@@ -1599,23 +1831,23 @@
;;======================================================================
;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
(case *transport-type*
- ((fs) obj)
- ((http)
+ ;; ((fs) obj)
+ ((http fs)
(string-substitute
(regexp "=") "_"
(base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
#t))
((zmq)(with-output-to-string (lambda ()(serialize obj))))
(else obj)))
(define (db:string->obj msg)
(case *transport-type*
- ((fs) msg)
- ((http)
+ ;; ((fs) msg)
+ ((http fs)
(if (string? msg)
(with-input-from-string
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t))
@@ -1622,235 +1854,102 @@
(lambda ()(deserialize)))
(vector #f #f #f))) ;; crude reply for when things go awry
((zmq)(with-input-from-string msg (lambda ()(deserialize))))
(else msg)))
-(define (cdb:use-non-blocking-mode proc)
- (set! *client-non-blocking-mode* #t)
- (let ((res (proc)))
- (set! *client-non-blocking-mode* #f)
- res))
-
-;; params = 'target cached remparams
-;;
-;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
-;;
-;; cdb:client-call is the unified interface to all the transports. It dispatches the
-;; query to a server routine (e.g. server:client-send-recieve) that
-;; transports the data to the server where it is passed to db:process-queue-item
-;; which either returns the data to the calling server routine or
-;; directly calls the returning procedure (e.g. zmq).
-;;
-(define (cdb:client-call serverdat qtype immediate numretries . params)
- (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params)
- (case *transport-type*
- ((fs)
- (let ((packet (vector "na" qtype immediate "na" params 0)))
- (fs:process-queue-item packet)))
- ((http)
- (let* ((client-sig (client:get-signature))
- (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params)))
- (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params))))
- (debug:print-info 11 "zdat=" zdat)
- (let* ((res #f)
- (rawdat (http-transport:client-send-receive serverdat zdat))
- (tmp #f))
- (debug:print-info 11 "Sent " zdat ", received " rawdat)
- (if rawdat
- (begin
- (set! tmp (db:string->obj rawdat))
- (vector-ref tmp 2))
- (begin
- (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible")
- (exit 1))))))
- ((zmq)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds")
- (thread-sleep! 5)
- (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
- (let* ((push-socket (vector-ref serverdat 0))
- (sub-socket (vector-ref serverdat 1))
- (client-sig (client:get-signature))
- (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params)))
- (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params))))
- (res #f)
- (send-receive (lambda ()
- (debug:print-info 11 "sending message")
- (send-message push-socket zdat)
- (debug:print-info 11 "message sent")
- (let loop ()
- ;; get the sender info
- ;; this should match (client:get-signature)
- ;; we will need to process "all" messages here some day
- (receive-message* sub-socket)
- ;; now get the actual message
- (let ((myres (db:string->obj (receive-message* sub-socket))))
- (if (equal? query-sig (vector-ref myres 1))
- (set! res (vector-ref myres 2))
- (loop)))))))
- ;; (timeout (lambda ()
- ;; (let loop ((n numretries))
- ;; (thread-sleep! 15)
- ;; (if (not res)
- ;; (if (> numretries 0)
- ;; (begin
- ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend")
- ;; (debug:print-info 11 "re-sending message")
- ;; (send-message push-socket zdat)
- ;; (debug:print-info 11 "message re-sent")
- ;; (loop (- n 1)))
- ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params))
- ;; (begin
- ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
- ;; (exit 5))))))))
- (debug:print-info 11 "Starting threads")
- (let ((th1 (make-thread send-receive "send receive"))
- ;; (th2 (make-thread timeout "timeout"))
- )
- (thread-start! th1)
- ;; (thread-start! th2)
- (thread-join! th1)
- (debug:print-info 11 "cdb:client-call returning res=" res)
- res))))))
-
-(define (cdb:set-verbosity serverdat val)
- (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))
-
-(define (cdb:login serverdat keyval signature)
- (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))
-
-(define (cdb:logout serverdat keyval signature)
- (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))
-
-(define (cdb:num-clients serverdat)
- (cdb:client-call serverdat 'numclients #t *default-numtries*))
-
-;; I think this would be more efficient if executed on client side FIXME???
-(define (cdb:test-set-status-state serverdat test-id status state msg)
+(define (db:test-set-status-state dbstruct run-id test-id status state msg)
+ (let ((db (db:get-db dbstruct run-id)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id))
+ (db:general-call db 'set-test-start-time (list test-id)))
(if msg
- (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id)
- (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree)
-
-(define (cdb:test-rollup-test_data-pass-fail serverdat test-id)
- (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id))
-
-(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count)
- (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id))
-
-(define (cdb:tests-register-test serverdat run-id test-name item-path)
- (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))
-
-;; more transactioned calls, these for roll-up-pass-fail stuff
-(define (cdb:update-pass-fail-counts serverdat run-id test-name)
- (cdb:client-call serverdat 'update-fail-pass-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name))
-
-(define (cdb:top-test-set-running serverdat run-id test-name)
- (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name))
-
-(define (cdb:top-test-set-per-pf-counts serverdat run-id test-name)
- (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name run-id test-name))
-
-;;=
-
-(define (cdb:flush-queue serverdat)
- (cdb:client-call serverdat 'flush #f *default-numtries*))
-
-(define (cdb:kill-server serverdat pid)
- (cdb:client-call serverdat 'killserver #t *default-numtries* pid))
-
-(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status)
- (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))
-
-(define (cdb:get-test-info serverdat run-id test-name item-path)
- (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))
-
-(define (cdb:get-test-info-by-id serverdat test-id)
- (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)))
- (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed
- test-dat))
-
-;; db should be db open proc or #f
-(define (cdb:remote-run proc db . params)
- (if (or *db-write-access*
- (not (member proc *db:all-write-procs*)))
- (handle-exceptions
- exn
- (let ((sleep-time (random 20))
- (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (case err-status
- ((busy)(thread-sleep! 4))
- (else
- (debug:print 0 "WARNING: possible problem with call to cdb:remote-run, database may be read-only and locked, waiting and trying again ...")
- (thread-sleep! sleep-time)))
- (apply cdb:remote-run proc db params))
- (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))
- (begin
- (debug:print 0 "ERROR: Attempt to access read-only database")
- #f)))
-
-(define (db:test-get-logfile-info db run-id test-name)
+ (db:general-call db 'state-status-msg (list state status msg test-id))
+ (db:general-call db 'state-status (list state status test-id)))))
+
+(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status)
+ (if (and (not (equal? item-path ""))
+ (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
+ (let ((db (db:get-db dbstruct run-id)))
+ (db:general-call db 'update-pass-fail-counts (list test-name test-name test-name))
+ (if (equal? status "RUNNING")
+ (db:general-call db 'top-test-set-running (list test-name))
+ (db:general-call db 'top-test-set-per-pf-counts (list test-name test-name test-name)))
+ #f)
+ #f))
+
+(define (db:tests-register-test dbstruct run-id test-name item-path)
+ (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path))
+;; (let ((sleep-time (random 20))
+;; (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+;; (case err-status
+;; ((busy)(thread-sleep! 4))
+;; (else
+;; (debug:print 0 "WARNING: possible problem with call to cdb:remote-run, database may be read-only and locked, waiting and trying again ...")
+;; (thread-sleep! sleep-time)))
+
+(define (db:test-get-logfile-info dbstruct run-id test-name)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path final_logf)
+ ;; (let ((path (sdb:qry 'getstr path-id))
+ ;; (final_logf (sdb:qry 'getstr final_logf-id)))
(set! logf final_logf)
(set! res (list path final_logf))
(if (directory? path)
(debug:print 2 "Found path: " path)
- (debug:print 2 "No such path: " path)))
- db
- "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';"
- run-id test-name)
+ (debug:print 2 "No such path: " path))) ;; )
+ (db:get-db dbstruct run-id)
+ "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';"
+ test-name)
res))
;;======================================================================
;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S
;;======================================================================
(define db:queries
- (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
+ (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
+
+ ;; TESTS
+ '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
;; Test state and status
'(set-test-state "UPDATE tests SET state=? WHERE id=?;")
'(set-test-status "UPDATE tests SET state=? WHERE id=?;")
- '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;")
- '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")
+ '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE
+ '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
;; Test comment
'(set-test-comment "UPDATE tests SET comment=? WHERE id=?;")
- '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;")
- '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;")
+ '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
+ '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
'(test_data-pf-rollup "UPDATE tests
SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
THEN 'FAIL'
WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
(SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
THEN 'PASS'
ELSE status
- END WHERE id=?;")
- '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;")
- '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")
- '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;")
- '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;")
+ 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=?;")
+ '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE
'(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=?;")
- '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
- '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;")
+ '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
+ '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
'(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
'(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-fail-pass-counts "UPDATE tests
- SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
- pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
- WHERE run_id=? AND testname=? AND item_path='';")
- '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';")
+ '(update-pass-fail-counts "UPDATE tests
+ SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
+ 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-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE
'(top-test-set-per-pf-counts "UPDATE tests
SET state=CASE
WHEN (SELECT count(id) FROM tests
- WHERE run_id=? AND testname=?
+ WHERE testname=?
AND item_path != ''
AND status NOT IN ('TEN_STRIKES','BLOCKED')
AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
ELSE 'COMPLETED' END,
status=CASE
@@ -1859,16 +1958,24 @@
AND item_path != ''
AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL'
WHEN fail_count > 0 THEN 'FAIL'
WHEN pass_count > 0 AND fail_count=0 THEN 'PASS'
WHEN (SELECT count(id) FROM tests
- WHERE run_id=? AND testname=?
+ WHERE testname=?
AND item_path != ''
AND status = 'SKIP') > 0 THEN 'SKIP'
ELSE 'UNKNOWN' END
- WHERE run_id=? AND testname=? AND item_path='';")
+ WHERE testname=? AND item_path='';") ;; DONE
+
+ ;; STEPS
+ '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;")
+ '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE id=?;") ;; using status since no state field
))
+
+(define (db:lookup-query qry-name)
+ (let ((q (alist-ref qry-name db:queries)))
+ (if q (car q) #f)))
;; do not run these as part of the transaction
(define db:special-queries '(rollup-tests-pass-fail
;; db:roll-up-pass-fail-counts ;; WHY NOT!?
login
@@ -1877,121 +1984,107 @@
sync
set-verbosity
killserver
))
-;; not used, intended to indicate to run in calling process
-(define db:run-local-queries '()) ;; rollup-tests-pass-fail))
-
-(define (db:process-cached-writes db)
- (let ((queries (make-hash-table))
- (data #f))
- (mutex-lock! *incoming-mutex*)
- ;; data is a list of query packets (length data) 0)
- ;; Process if we have data
- (begin
- (debug:print-info 7 "Writing cached data " data)
-
- ;; Prepare the needed sql statements
- ;;
- (for-each (lambda (request-item)
- (let ((stmt-key (vector-ref request-item 0))
- (query (vector-ref request-item 1)))
- (hash-table-set! queries stmt-key (sqlite3:prepare db query))))
- data)
-
- ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue
- ;; and then are executed.
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (hed)
- (let* ((params (vector-ref hed 2))
- (stmt-key (vector-ref hed 0))
- (stmt (hash-table-ref/default queries stmt-key #f)))
- (if stmt
- (begin
- (db:delay-if-busy)
- (apply sqlite3:execute stmt params))
- (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params))))
- data)))
-
- ;; let all the waiting calls know all is done
- (mutex-lock! *completed-mutex*)
- (for-each (lambda (item)
- (let ((qry-sig (cdb:packet-get-client-sig item)))
- (debug:print-info 7 "Registering query " qry-sig " as done")
- (hash-table-set! *completed-writes* qry-sig #t)))
- data)
- (mutex-unlock! *completed-mutex*)
-
- ;; Finalize the statements. Should this be done inside the mutex above?
- ;; I think sqlite3 mutexes will keep the data safe
- (for-each (lambda (stmt-key)
- (sqlite3:finalize! (hash-table-ref queries stmt-key)))
- (hash-table-keys queries))
-
- ;; Do a little record keeping
- (let ((cache-size (length data)))
- (if (> cache-size *max-cache-size*)
- (set! *max-cache-size* cache-size)))
- #t)
- #f)))
-
-(define *db:process-queue-mutex* (make-mutex))
-
-(define *number-of-writes* 0)
-(define *writes-total-delay* 0)
-(define *total-non-write-delay* 0)
-(define *number-non-write-queries* 0)
-
-;; The queue is a list of vectors where the zeroth slot indicates the type of query to
-;; apply and the second slot is the time of the query and the third entry is a list of
-;; values to be applied
-;;
-(define (db:queue-write-and-wait db qry-sig query params)
- (let ((queue-len 0)
- (res #f)
- (got-it #f)
- (qry-pkt (vector qry-sig query params))
- (start-time (current-milliseconds))
- (timeout (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future
-
- ;; Put the item in the queue *incoming-writes*
- (mutex-lock! *incoming-mutex*)
- (set! *incoming-writes* (cons qry-pkt *incoming-writes*))
- (set! queue-len (length *incoming-writes*))
- (mutex-unlock! *incoming-mutex*)
-
- (debug:print-info 7 "Current write queue length is " queue-len)
-
- ;; poll for the write to complete, timeout after 10 seconds
- ;; periodic flushing of the queue is taken care of by
- ;; db:flush-queue
- (let loop ()
- (thread-sleep! 0.001)
- (mutex-lock! *completed-mutex*)
- (if (hash-table-ref/default *completed-writes* qry-sig #f)
- (begin
- (hash-table-delete! *completed-writes* qry-sig)
- (set! got-it #t)))
- (mutex-unlock! *completed-mutex*)
- (if (and (not got-it)
- (< (current-seconds) timeout))
- (begin
- (thread-sleep! 0.01)
- (loop))))
- (set! *number-of-writes* (+ *number-of-writes* 1))
- (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time)))
- got-it))
-
+(define (db:login dbstruct calling-path calling-version run-id 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? 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"))))
+
+(define (db:general-call db stmtname params)
+ (let ((query (let ((q (alist-ref (if (string? stmtname)
+ (string->symbol stmtname)
+ stmtname)
+ db:queries)))
+ (if q (car q) #f))))
+ (apply sqlite3:execute db query params)
+ #t))
+
+;; get the previous records for when these tests were run where all keys match but runname
+;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
+;; can use wildcards. Also can likely be factored in with get test paths?
+;;
+;; Run this remotely!!
+;;
+(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
+ (let* ((db (db:get-db dbstruct #f))
+ (keys (db:get-keys db))
+ (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
+ (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
+ (keyvals #f)
+ (tests-hash (make-hash-table)))
+ ;; first look up the key values from the run selected by run-id
+ (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)
+ (if (not keyvals)
+ '()
+ (let ((prev-run-ids '()))
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
+ ;; collect all matching tests for the runs then
+ ;; extract the most recent test and return that.
+ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
+ ", previous run ids found: " prev-run-ids)
+ (if (null? prev-run-ids) '() ;; no previous runs? return null
+ (let loop ((hed (car prev-run-ids))
+ (tal (cdr prev-run-ids)))
+ (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
+ (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
+ ", item-path " item-path " results: " (intersperse results "\n"))
+ ;; Keep only the youngest of any test/item combination
+ (for-each
+ (lambda (testdat)
+ (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
+ (stored-test (hash-table-ref/default tests-hash full-testname #f)))
+ (if (or (not stored-test)
+ (and stored-test
+ (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
+ ;; this test is younger, store it in the hash
+ (hash-table-set! tests-hash full-testname testdat))))
+ results)
+ (if (null? tal)
+ (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
+ (loop (car tal)(cdr tal))))))))))
+;; (let* ((remtries 10)
+;; (proc #f))
+;; (set! proc (lambda (remtries)
+;; (if (> remtries 0)
+;; (handle-exceptions
+;; exn
+;; (let ((sleep-time (random 30))
+;; (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+;; (case err-status
+;; ((busy)
+;; (thread-sleep! sleep-time)
+;; (proc 10)) ;; we never give up on busy
+;; (else
+;; (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
+;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+;; (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+;; (print-call-chain)
+;; (debug:print 0 "Sleeping for " sleep-time)
+;; (thread-sleep! sleep-time)
+;; (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")
+;; (proc (- remtries 1)))))
+;; (apply sqlite3:execute db query params))
+;; (debug:print 0 "ERROR: too many attempts to access db were made and no sucess. query: "
+;; query ", params: " params))))
+;; (proc remtries))
(define (db:delay-if-busy #!key (count 6))
(let ((dbfj (conc *toppath* "/megatest.db-journal")))
(if (file-exists? dbfj)
(case count
((6)
@@ -2013,468 +2106,59 @@
(thread-sleep! 6.4)
(db:delay-if-busy count: 0))
(else
(debug:print-info 0 "delaying db access due to high database load.")
(thread-sleep! 12.8))))))
-
-(define (db:process-queue-item db item)
- (let* ((stmt-key (cdb:packet-get-qtype item))
- (qry-sig (cdb:packet-get-query-sig item))
- (return-address (cdb:packet-get-client-sig item))
- (params (cdb:packet-get-params item))
- (query (let ((q (alist-ref stmt-key db:queries)))
- (if q (car q) #f))))
- (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params)
- (if query
- ;; hand queries off to the write queue
- (let ((response (case *transport-type*
- ((http)
- (debug:print-info 7 "Queuing item " item " for wrapped write")
- (db:queue-write-and-wait db qry-sig query params))
- (else
- (let* ((remtries 10)
- (proc #f))
- (set! proc (lambda (remtries)
- (if (> remtries 0)
- (handle-exceptions
- exn
- (let ((sleep-time (random 30))
- (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (case err-status
- ((busy)
- (thread-sleep! sleep-time)
- (proc 10)) ;; we never give up on busy
- (else
- (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (print-call-chain)
- (debug:print 0 "Sleeping for " sleep-time)
- (thread-sleep! sleep-time)
- (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")
- (proc (- remtries 1)))))
- (begin
- (db:delay-if-busy)
- (apply sqlite3:execute db query params)))
- (debug:print 0 "ERROR: too many attempts to access db were made and no sucess. query: "
- query ", params: " params))))
- (proc remtries))
- #t))))
- (debug:print-info 7 "Received " response " from wrapped write")
- (server:reply return-address qry-sig response response))
- ;; otherwise if appropriate flush the queue (this is a read or complex query)
- (begin
- (cond
- ((member stmt-key db:special-queries)
- (let ((starttime (current-milliseconds)))
- (debug:print-info 9 "Handling special statement " stmt-key)
- (case stmt-key
- ((immediate)
- ;; This is a read or mixed read-write query, must clear the cache
- (case *transport-type*
- ((http)
- (mutex-lock! *db:process-queue-mutex*)
- (db:process-cached-writes db)
- (mutex-unlock! *db:process-queue-mutex*)))
- (let* ((proc (car params))
- (remparams (cdr params))
- ;; we are being handed a procedure so call it
- ;; (debug:print-info 11 "Running (apply " proc " " remparams ")")
- (result (server:reply return-address qry-sig #t (apply proc remparams))))
- (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime)))
- (set! *number-non-write-queries* (+ *number-non-write-queries* 1))
- result))
- ((login)
- (if (< (length params) 3) ;; should get toppath, version and signature
- (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params
- (let ((calling-path (car params))
- (calling-vers (cadr params))
- (client-key (caddr params)))
- (if (and (equal? calling-path *toppath*)
- (equal? megatest-version calling-vers))
- (begin
- (hash-table-set! *logged-in-clients* client-key (current-seconds))
- (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ...
- (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
- ((flush sync)
- (server:reply return-address qry-sig #t 1)) ;; (length data)))
- ((set-verbosity)
- (set! *verbosity* (car params))
- (server:reply return-address qry-sig #t (list #t *verbosity*)))
- ((killserver)
- (let ((hostname (car *runremote*))
- (port (cadr *runremote*))
- (pid (car params)))
- (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
- (debug:print-info 1 "current pid=" (current-process-id))
- (open-run-close tasks:server-deregister tasks:open-db
- hostname
- port: port)
- (set! *server-run* #f)
- (thread-sleep! 3)
- (process-signal pid signal/kill)
- (server:reply return-address qry-sig #t '(#t "exit process started"))))
- (else ;; not a command, i.e. is a query
- (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
- (server:reply return-address qry-sig #f 'failed)))))
- (else
- (debug:print-info 11 "Executing " stmt-key " for " params)
- (db:delay-if-busy)
- (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
- (server:reply return-address qry-sig #t #t)))))))
-
-(define (db:test-get-records-for-index-file db run-id test-name)
+;; (db:delay-if-busy)
+;; (apply sqlite3:execute db query params)))
+;; (db:delay-if-busy)
+
+(define (db:test-get-records-for-index-file dbstruct run-id test-name)
(let ((res '()))
(sqlite3:for-each-row
- (lambda (id itempath state status run_duration logf comment)
+ (lambda (id itempath state status run_duration logf-id comment-id)
+ (let ((logf (db:get-string dbstruct logf-id))
+ (comment (db:get-string dbstruct comment-id)))
(set! res (cons (vector id itempath state status run_duration logf comment) res)))
- db
- "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"
- run-id test-name)
- res))
+ (db:get-db dbstruct run-id)
+ "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';"
+ test-name)
+ res)))
;;======================================================================
;; Tests meta data
;;======================================================================
;; read the record given a testname
-(define (db:testmeta-get-record db testname)
+(define (db:testmeta-get-record dbstruct testname)
(let ((res #f))
(sqlite3:for-each-row
(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
(set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
- db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
+ (db:get-db dbstruct #f)
+ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
testname)
res))
;; create a new record for a given testname
-(define (db:testmeta-add-record db testname)
+(define (db:testmeta-add-record dbstruct testname)
(db:delay-if-busy)
- (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))
+ (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))
;; update one of the testmeta fields
-(define (db:testmeta-update-field db testname field value)
+(define (db:testmeta-update-field dbstruct testname field value)
(db:delay-if-busy)
- (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-
-(define (db:csv->test-data db test-id csvdata #!key (work-area #f))
- (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- (if (sqlite3:database? tdb)
- (let ((csvlist (csv->list (make-csv-reader
- (open-input-string csvdata)
- '((strip-leading-whitespace? #t)
- (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
- (for-each
- (lambda (csvrow)
- (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
- (category (list-ref padded-row 0))
- (variable (list-ref padded-row 1))
- (value (any->number-if-possible (list-ref padded-row 2)))
- (expected (any->number-if-possible (list-ref padded-row 3)))
- (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
- (units (list-ref padded-row 5))
- (comment (list-ref padded-row 6))
- (status (let ((s (list-ref padded-row 7)))
- (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
- (string-match (regexp "^n/a$") s)))
- #f
- s))) ;; if specified on the input then use, else calculate
- (type (list-ref padded-row 8)))
- ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
- (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
-
- (if (and (or (not expected)(equal? expected ""))
- (or (not tol) (equal? expected ""))
- (or (not units) (equal? expected "")))
- (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable)))
- (set! expected new-expected)
- (set! tol new-tol)
- (set! units new-units)))
-
- (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; calculate status if NOT specified
- (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
- (if (number? tol) ;; if tol is a number then we do the standard comparison
- (let* ((max-val (+ expected tol))
- (min-val (- expected tol))
- (result (and (>= value min-val)(<= value max-val))))
- (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
- (set! status (if result "pass" "fail")))
- (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
- (case (string->symbol tol) ;; tol should be >, <, >=, <=
- ((>) (if (> value expected) "pass" "fail"))
- ((<) (if (< value expected) "pass" "fail"))
- ((>=) (if (>= value expected) "pass" "fail"))
- ((<=) (if (<= value expected) "pass" "fail"))
- (else (conc "ERROR: bad tol comparator " tol))))))
- (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- (sqlite3:execute tdb "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)
- (sqlite3:finalize! tdb)))))
-
-;; get a list of test_data records matching categorypatt
-(define (db:read-test-data db test-id categorypatt #!key (work-area #f))
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- (if (sqlite3:database? tdb)
- (let ((res '()))
- (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)))
- tdb
- "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)
- (sqlite3:finalize! tdb)
- (reverse res))
- '())))
-
-;; NOTE: Run this local with #f for db !!!
-(define (db:load-test-data db test-id #!key (work-area #f))
- (let loop ((lin (read-line)))
- (if (not (eof-object? lin))
- (begin
- (debug:print 4 lin)
- (db:csv->test-data db test-id lin work-area: work-area)
- (loop (read-line)))))
- ;; roll up the current results.
- ;; FIXME: Add the status to
- (db:test-data-rollup db test-id #f work-area: work-area))
-
-;; WARNING: Do NOT call this for the parent test on an iterated test
-;; Roll up test_data pass/fail results
-;; look at the test_data status field,
-;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
-;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
-(define (db:test-data-rollup db test-id status #!key (work-area #f))
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (fail-count 0)
- (pass-count 0))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:for-each-row
- (lambda (fcount pcount)
- (set! fail-count fcount)
- (set! pass-count pcount))
- tdb
- "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
- (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
- test-id test-id)
- (sqlite3:finalize! tdb)
-
- ;; Now rollup the counts to the central megatest.db
- (cdb:pass-fail-counts *runremote* test-id fail-count pass-count)
- ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;"
- ;; fail-count pass-count test-id)
-
- ;; The flush is not needed with the transaction based write agregation enabled. Remove these commented lines
- ;; next time you read this!
- ;;
- ;; (cdb:flush-queue *runremote*)
- ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set
-
- ;; if the test is not FAIL then set status based on the fail and pass counts.
- (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
- ;; (sqlite3:execute
- ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME
- ;; "UPDATE tests
- ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
- ;; THEN 'FAIL'
- ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
- ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
- ;; THEN 'PASS'
- ;; ELSE status
- ;; END WHERE id=?;"
- ;; test-id test-id test-id test-id)
- ))))
-
-(define (db:get-prev-tol-for-test db test-id category variable)
- ;; Finish me?
- (values #f #f #f))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-(define (db:step-get-time-as-string vec)
- (seconds->time-string (db:step-get-event_time vec)))
-
-;; db-get-test-steps-for-run
-(define (db:get-steps-for-test db test-id #!key (work-area #f))
- (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (res '()))
- (if (sqlite3:database? tdb)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: error on access to testdat for test with id " test-id)
- '())
- (begin
- (sqlite3:for-each-row
- (lambda (id test-id stepname state status event-time logfile)
- (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
- tdb
- "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-id)
- (sqlite3:finalize! tdb)
- (reverse res)))
- '())))
-
-;; get a pretty table to summarize steps
-;;
-(define (db:get-steps-table db test-id #!key (work-area #f))
- (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
- ;; organise the steps for better readability
- (let ((res (make-hash-table)))
- (for-each
- (lambda (step)
- (debug:print 6 "step=" step)
- (let ((record (hash-table-ref/default
- res
- (db:step-get-stepname step)
- ;; stepname start end status Duration Logfile
- (vector (db:step-get-stepname step) "" "" "" "" ""))))
- (debug:print 6 "record(before) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))
- (case (string->symbol (db:step-get-state step))
- ((start)(vector-set! record 1 (db:step-get-event_time step))
- (vector-set! record 3 (if (equal? (vector-ref record 3) "")
- (db:step-get-status step)))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- ((end)
- (vector-set! record 2 (any->number (db:step-get-event_time step)))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
- (endt (any->number (vector-ref record 2))))
- (debug:print 4 "record[1]=" (vector-ref record 1)
- ", startt=" startt ", endt=" endt
- ", get-status: " (db:step-get-status step))
- (if (and (number? startt)(number? endt))
- (seconds->hr-min-sec (- endt startt)) "-1")))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- (else
- (vector-set! record 2 (db:step-get-state step))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (db:step-get-event_time step))))
- (hash-table-set! res (db:step-get-stepname step) record)
- (debug:print 6 "record(after) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))))
- ;; (else (vector-set! record 1 (db:step-get-event_time step)))
- (sort steps (lambda (a b)
- (cond
- ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
- ((eq? (db:step-get-event_time a)(db:step-get-event_time b))
- (< (db:step-get-id a) (db:step-get-id b)))
- (else #f)))))
- res)))
-
-;; get a pretty table to summarize steps
-;;
-(define (db:get-steps-table-list db test-id #!key (work-area #f))
- (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
- ;; organise the steps for better readability
- (let ((res (make-hash-table)))
- (for-each
- (lambda (step)
- (debug:print 6 "step=" step)
- (let ((record (hash-table-ref/default
- res
- (db:step-get-stepname step)
- ;; stepname start end status
- (vector (db:step-get-stepname step) "" "" "" "" ""))))
- (debug:print 6 "record(before) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))
- (case (string->symbol (db:step-get-state step))
- ((start)(vector-set! record 1 (db:step-get-event_time step))
- (vector-set! record 3 (if (equal? (vector-ref record 3) "")
- (db:step-get-status step)))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- ((end)
- (vector-set! record 2 (any->number (db:step-get-event_time step)))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
- (endt (any->number (vector-ref record 2))))
- (debug:print 4 "record[1]=" (vector-ref record 1)
- ", startt=" startt ", endt=" endt
- ", get-status: " (db:step-get-status step))
- (if (and (number? startt)(number? endt))
- (seconds->hr-min-sec (- endt startt)) "-1")))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- (else
- (vector-set! record 2 (db:step-get-state step))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (db:step-get-event_time step))))
- (hash-table-set! res (db:step-get-stepname step) record)
- (debug:print 6 "record(after) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))))
- ;; (else (vector-set! record 1 (db:step-get-event_time step)))
- (sort steps (lambda (a b)
- (cond
- ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
- ((eq? (db:step-get-event_time a)(db:step-get-event_time b))
- (< (db:step-get-id a) (db:step-get-id b)))
- (else #f)))))
- res)))
-
-(define (db:get-compressed-steps test-id #!key (work-area #f)(tdb #f))
- (if (or (not work-area)
- (file-exists? (conc work-area "/testdat.db")))
- (let* ((comprsteps (open-run-close db:get-steps-table tdb test-id work-area: work-area)))
- (map (lambda (x)
- ;; take advantage of the \n on time->string
- (vector
- (vector-ref x 0)
- (let ((s (vector-ref x 1)))
- (if (number? s)(seconds->time-string s) s))
- (let ((s (vector-ref x 2)))
- (if (number? s)(seconds->time-string s) s))
- (vector-ref x 3) ;; status
- (vector-ref x 4)
- (vector-ref x 5))) ;; time delta
- (sort (hash-table-values comprsteps)
- (lambda (a b)
- (let ((time-a (vector-ref a 1))
- (time-b (vector-ref b 1)))
- (if (and (number? time-a)(number? time-b))
- (if (< time-a time-b)
- #t
- (if (eq? time-a time-b)
- (string (conc (vector-ref a 2))
- (conc (vector-ref b 2)))
- #f))
- (string (conc time-a)(conc time-b))))))))
- '()))
+ (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))
+
+(define (db:testmeta-get-all dbstruct)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (cons (apply vector a b) res)))
+ (db:get-db dbstruct run-id)
+ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
+ res))
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
@@ -2499,21 +2183,23 @@
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;; mode 'toplevel means that tests must be COMPLETED only
;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;;
-(define (db:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f))
+;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
+(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f))
(if (or (not waitons)
(null? waitons))
'()
(let* ((unmet-pre-reqs '())
(result '()))
(for-each
(lambda (waitontest-name)
;; by getting the tests with matching name we are looking only at the matching test
;; and related sub items
- (let ((tests (cdb:remote-run db:get-tests-for-run-state-status #f run-id waitontest-name)) ;; (mt:get-tests-for-run run-id waitontest-name '() '()))
+ ;; next should be using mt:get-tests-for-run?
+ (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
(ever-seen #f)
(parent-waiton-met #f)
(item-waiton-met #f))
(for-each
(lambda (test)
@@ -2563,35 +2249,19 @@
(if (not ever-seen)
(set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
waitons)
(delete-duplicates result))))
-(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f))
- ;; db:open-test-db-by-test-id does cdb:remote-run
- (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (state (items:check-valid-items "state" state-in))
- (status (items:check-valid-items "status" status-in)))
- (if (or (not state)(not status))
- (debug:print 3 "WARNING: Invalid " (if status "status" "state")
- " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:execute
- tdb
- "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
- test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))
- (sqlite3:finalize! tdb)
- #t)
- #f)))
-
;;======================================================================
;; Extract ods file from the db
;;======================================================================
+
+;; NOT REWRITTEN YET!!!!!
;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
-(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod)
+(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
(let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
(keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
(numkeys (length keypatt-alist))
(test-ids '())
(windows (and pathmod (substring-index "\\" pathmod)))
@@ -2708,27 +2378,25 @@
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
;; This is a list of all procs that write to the db
;;
-(define *db:all-write-procs*
- (list
- db:set-var
- db:del-var
- db:register-run
- db:set-comment-for-run
- db:delete-run
- db:update-run-event_time
- db:lock/unlock-run
- db:delete-test-step-records
- db:delete-test-records
- db:delete-tests-for-run
- db:delete-old-deleted-test-records
- db:set-tests-state-status
- db:test-set-state-status-by-id
- db:test-set-state-status-by-run-id-testname
- db:test-set-comment
- db:testmeta-add-record
- db:csv->test-data
- db:test-data-rollup
- db:teststep-set-status! ))
+;; (define *db:all-write-procs*
+;; (list
+;; db:set-var
+;; db:del-var
+;; db:register-run
+;; db:set-comment-for-run
+;; db:delete-run
+;; db:update-run-event_time
+;; db:lock/unlock-run
+;; db:delete-test-step-records
+;; db:delete-test-records
+;; db:delete-tests-for-run
+;; db:delete-old-deleted-test-records
+;; db:set-tests-state-status
+;; db:test-set-state-status-by-id
+;; db:test-set-state-status-by-run-id-testname
+;; db:testmeta-add-record
+;; db:csv->test-data
+;; ))
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -1,7 +1,68 @@
-;; Test record accessors
+;;======================================================================
+;; dbstruct
+;;======================================================================
+
+;;
+;; -path-|-megatest.db
+;; |-db-|-main.db
+;; |-monitor.db
+;; |-sdb.db
+;; |-fdb.db
+;; |-1.db
+;; |-.db
+;;
+;;
+;; Accessors for a dbstruct
+;;
+
+(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
+(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1))
+(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2))
+(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3))
+(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4))
+(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5))
+(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6))
+(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7))
+(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8))
+(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9))
+(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10))
+(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11))
+(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12))
+;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13))
+
+(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val))
+(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val))
+(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val))
+(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val))
+(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val))
+(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val))
+(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val))
+(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val))
+(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val))
+(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val))
+(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val))
+(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val))
+(define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val))
+; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val))
+
+;; constructor for dbstruct
;;
+(define (make-dbr:dbstruct #!key (path #f)(local #f))
+ (let ((v (make-vector 14 #f)))
+ (dbr:dbstruct-set-path! v path)
+ (dbr:dbstruct-set-local! v local)
+ (dbr:dbstruct-set-locdbs! v (make-hash-table))
+ v))
+
+(define (dbr:dbstruct-get-localdb v run-id)
+ (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f))
+
+(define (dbr:dbstruct-set-localdb! v run-id db)
+ (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db))
+
+
(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id vec) (vector-ref vec 1))
(define-inline (db:test-get-testname vec) (vector-ref vec 2))
(define-inline (db:test-get-state vec) (vector-ref vec 3))
@@ -9,15 +70,18 @@
(define-inline (db:test-get-event_time vec) (vector-ref vec 5))
(define-inline (db:test-get-host vec) (vector-ref vec 6))
(define-inline (db:test-get-cpuload vec) (vector-ref vec 7))
(define-inline (db:test-get-diskfree vec) (vector-ref vec 8))
(define-inline (db:test-get-uname vec) (vector-ref vec 9))
+;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define-inline (db:test-get-rundir vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf vec) (vector-ref vec 13))
(define-inline (db:test-get-comment vec) (vector-ref vec 14))
+(define-inline (db:test-get-pass_count vec) (vector-ref vec 15))
+(define-inline (db:test-get-fail_count vec) (vector-ref vec 16))
(define-inline (db:test-get-fullname vec)
(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16)))
@@ -36,14 +100,10 @@
;;
(define (db:test-get-is-toplevel vec)
(and (equal? (db:test-get-item-path vec) "") ;; test is not an item
(equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
-;; get rows and header from
-(define-inline (db:get-header vec)(vector-ref vec 0))
-(define-inline (db:get-rows vec)(vector-ref vec 1))
-
;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;;
(define (make-db:mintest)(make-vector 7))
(define-inline (db:mintest-get-id vec) (vector-ref vec 0))
(define-inline (db:mintest-get-run_id vec) (vector-ref vec 1))
@@ -107,41 +167,38 @@
;; S T E P S
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
(define (make-db:step)(make-vector 7))
-(define-inline (db:step-get-id vec) (vector-ref vec 0))
-(define-inline (db:step-get-test_id vec) (vector-ref vec 1))
-(define-inline (db:step-get-stepname vec) (vector-ref vec 2))
-(define-inline (db:step-get-state vec) (vector-ref vec 3))
-(define-inline (db:step-get-status vec) (vector-ref vec 4))
-(define-inline (db:step-get-event_time vec) (vector-ref vec 5))
-(define-inline (db:step-get-logfile vec) (vector-ref vec 6))
-(define-inline (db:step-set-id! vec val)(vector-set! vec 0 val))
-(define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val))
-(define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val))
-(define-inline (db:step-set-state! vec val)(vector-set! vec 3 val))
-(define-inline (db:step-set-status! vec val)(vector-set! vec 4 val))
-(define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val))
-(define-inline (db:step-set-logfile! vec val)(vector-set! vec 6 val))
+(define-inline (tdb:step-get-id vec) (vector-ref vec 0))
+(define-inline (tdb:step-get-test_id vec) (vector-ref vec 1))
+(define-inline (tdb:step-get-stepname vec) (vector-ref vec 2))
+(define-inline (tdb:step-get-state vec) (vector-ref vec 3))
+(define-inline (tdb:step-get-status vec) (vector-ref vec 4))
+(define-inline (tdb:step-get-event_time vec) (vector-ref vec 5))
+(define-inline (tdb:step-get-logfile vec) (vector-ref vec 6))
+(define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val))
+(define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
+(define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
+(define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val))
+(define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val))
+(define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
+(define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
;; The steps table
(define (make-db:steps-table)(make-vector 5))
-(define-inline (db:steps-table-get-stepname vec) (vector-ref vec 0))
-(define-inline (db:steps-table-get-start vec) (vector-ref vec 1))
-(define-inline (db:steps-table-get-end vec) (vector-ref vec 2))
-(define-inline (db:steps-table-get-status vec) (vector-ref vec 3))
-(define-inline (db:steps-table-get-runtime vec) (vector-ref vec 4))
-(define-inline (db:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
-(define-inline (db:step-stable-set-start! vec val)(vector-set! vec 1 val))
-(define-inline (db:step-stable-set-end! vec val)(vector-set! vec 2 val))
-(define-inline (db:step-stable-set-status! vec val)(vector-set! vec 3 val))
-(define-inline (db:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
-
-;; use this one for db-get-run-info
-(define-inline (db:get-row vec)(vector-ref vec 1))
+(define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
+(define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1))
+(define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2))
+(define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3))
+(define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
+(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
+(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
+(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
+(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
+(define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
;; The data structure for handing off requests via wire
(define (make-cdb:packet)(make-vector 6))
(define-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0))
(define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1))
ADDED dbwars/NOTES
Index: dbwars/NOTES
==================================================================
--- /dev/null
+++ dbwars/NOTES
@@ -0,0 +1,31 @@
+Before using prepare:
+
+matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
+Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far)
+Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far)
+Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far)
+create-tests ran register-test 144000 times in 41.0 seconds
+
+After using prepare:
+
+matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert
+Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far)
+Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far)
+Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far)
+create-tests ran register-test 144000 times in 38.0 seconds
+
+After moving the prepare outside the call (so it isn't done each time):
+
+matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
+Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far)
+Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far)
+Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far)
+create-tests ran register-test 144000 times in 33.0 seconds
+
+Using sql-de-lite with very similar code:
+
+matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert
+Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far)
+Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far)
+create-tests ran register-test 144000 times in 31.0 seconds
+
ADDED dbwars/sql-de-lite-test.scm
Index: dbwars/sql-de-lite-test.scm
==================================================================
--- /dev/null
+++ dbwars/sql-de-lite-test.scm
@@ -0,0 +1,19 @@
+
+(use sql-de-lite)
+(include "test-common.scm")
+
+(define db (open-database "test.db"))
+
+(exec (sql db test-table-defn))
+(exec (sql db syncsetup))
+
+(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
+ (exec
+ stmth ;; (sql db test-insert)
+ run-id
+ testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
+
+(let ((stmth (sql db test-insert)))
+ (create-tests stmth))
+
+(close-database db)
ADDED dbwars/sqlite3-test.scm
Index: dbwars/sqlite3-test.scm
==================================================================
--- /dev/null
+++ dbwars/sqlite3-test.scm
@@ -0,0 +1,20 @@
+
+(use sqlite3)
+(include "test-common.scm")
+
+(define db (open-database "test.db"))
+
+(execute db test-table-defn)
+(execute db syncsetup)
+
+
+(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
+ (execute stmth
+ run-id
+ testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
+
+(let ((stmth (prepare db test-insert)))
+ (create-tests stmth)
+ (finalize! stmth))
+
+(finalize! db)
ADDED dbwars/test-common.scm
Index: dbwars/test-common.scm
==================================================================
--- /dev/null
+++ dbwars/test-common.scm
@@ -0,0 +1,129 @@
+(use srfi-18 srfi-69 apropos)
+
+(define args (argv))
+
+(if (not (eq? (length args) 2))
+ (begin
+ (print "Usage: sqlitecompare [insert|update]")
+ (exit 0)))
+
+(define action (string->symbol (cadr args)))
+
+(system "rm -f test.db")
+
+(define test-table-defn
+ "CREATE TABLE IF NOT EXISTS tests
+ (id INTEGER PRIMARY KEY,
+ run_id INTEGER,
+ testname TEXT,
+ host TEXT DEFAULT 'n/a',
+ cpuload REAL DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ uname TEXT DEFAULT 'n/a',
+ rundir TEXT DEFAULT 'n/a',
+ shortdir TEXT DEFAULT '',
+ item_path TEXT DEFAULT '',
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'FAIL',
+ attemptnum INTEGER DEFAULT 0,
+ final_logf TEXT DEFAULT 'logs/final.log',
+ logdat BLOB,
+ run_duration INTEGER DEFAULT 0,
+ comment TEXT DEFAULT '',
+ event_time TIMESTAMP,
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
+ CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
+ );")
+
+(define test-insert "INSERT INTO tests (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time)
+ values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );")
+(define syncsetup "PRAGMA synchronous = OFF;")
+
+(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9"))
+(define items '())
+(for-each
+ (lambda (n)
+ (for-each
+ (lambda (m)
+ (set! items (cons (conc "item/" n m) items)))
+ '(0 1 2 3 4 5 6 7 8 9)))
+ '(0 1 2 3 4 5 6 7 8 9))
+(define hosts '("host0" "host1" "host2")) ;; "host3" "host4" "host5" "host6" "host7" "host8" "host9"))
+(define cpuloads '(0.1 0.2 0.3)) ;; 0.4 0.5 0.6 0.7 0.8 0.9))
+(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000))
+(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux")
+(define basedir "/mfs/matt/data/megatest/runs/testing")
+(define final-logf "finallog.html")
+(define run-durations (list 120 240)) ;; 260))
+(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?"))
+
+(define run-ids (make-hash-table))
+(define max-run-id 1000)
+
+(define (test-factors->run-id host cpuload diskfree run-duration comment)
+ (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment))
+ (run-id (hash-table-ref/default run-ids factor #f)))
+ (if run-id
+ (list run-id factor)
+ (let ((new-id (+ max-run-id 1)))
+ (set! max-run-id new-id)
+ (hash-table-set! run-ids factor new-id)
+ (list new-id factor)))))
+
+
+(define (create-tests stmth)
+ (let ((num-created 0)
+ (last-print (current-seconds))
+ (start-time (current-seconds)))
+ (for-each
+ (lambda (test)
+ (for-each
+ (lambda (item)
+ (for-each
+ (lambda (host)
+ (for-each
+ (lambda (cpuload)
+ (for-each
+ (lambda (diskfree)
+ (for-each
+ (lambda (run-duration)
+ (for-each
+ (lambda (comment)
+ (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment))
+ (run-id (car run-id-dat))
+ (factor (cadr run-id-dat))
+ (curr-time (current-seconds)))
+ (if (> (- curr-time last-print) 10)
+ (begin
+ (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)")
+ (set! last-print curr-time)))
+ (set! num-created (+ num-created 1))
+ (register-test stmth ;; db
+ run-id
+ test ;; testname
+ host
+ cpuload
+ diskfree
+ uname
+ (conc basedir "/" test "/" item) ;; rundir
+ (conc test "/" item) ;; shortdir
+ item ;; item-path
+ "NOT_STARTED" ;; state
+ "NA" ;; status
+ final-logf
+ run-duration
+ comment
+ (current-seconds))))
+ comments))
+ run-durations))
+ diskfrees))
+ cpuloads))
+ hosts))
+ items))
+ tests)
+ (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds")))
+
+
+
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -358,32 +358,32 @@
(define (dcommon:general-info)
(let ((general-matrix (iup:matrix
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
#:numcol 1
- #:numlin 3
+ #:numlin 2
#:numcol-visible 1
- #:numlin-visible 3)))
- (iup:attribute-set! general-matrix "WIDTH1" "200")
+ #:numlin-visible 2)))
+ (iup:attribute-set! general-matrix "WIDTH1" "150")
(iup:attribute-set! general-matrix "0:1" "About this Megatest area")
;; User (this is not always obvious - it is common to run as a different user
(iup:attribute-set! general-matrix "1:0" "User")
(iup:attribute-set! general-matrix "1:1" (current-user-name))
;; Megatest area
- (iup:attribute-set! general-matrix "2:0" "Area")
- (iup:attribute-set! general-matrix "2:1" *toppath*)
+ ;; (iup:attribute-set! general-matrix "2:0" "Area")
+ ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
;; Megatest version
- (iup:attribute-set! general-matrix "3:0" "Version")
- (iup:attribute-set! general-matrix "3:1" megatest-version)
+ (iup:attribute-set! general-matrix "2:0" "Version")
+ (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
general-matrix))
-(define (dcommon:run-stats)
+(define (dcommon:run-stats dbstruct)
(let* ((stats-matrix (iup:matrix expand: "YES"))
(changed #f)
(updater (lambda ()
- (let* ((run-stats (mt:get-run-stats))
+ (let* ((run-stats (db:get-run-stats dbstruct))
(indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell))
(row-indices (car indices))
(col-indices (cadr indices))
(max-row (if (null? row-indices) 1 (apply max (map cadr row-indices))))
(max-col (if (null? col-indices) 1
@@ -445,13 +445,13 @@
(let* ((colnum 0)
(rownum 0)
(servers-matrix (iup:matrix #:expand "YES"
#:numcol 7
#:numcol-visible 7
- #:numlin-visible 3
+ #:numlin-visible 5
))
- (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport"))
+ (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
(updater (lambda ()
(let ((servers (open-run-close tasks:get-all-servers tasks:open-db)))
(iup:attribute-set! servers-matrix "NUMLIN" (length servers))
;; (set! colnum 0)
;; (for-each (lambda (colname)
@@ -466,25 +466,27 @@
(let* ((vals (list (vector-ref server 0) ;; Id
(vector-ref server 9) ;; MT-Ver
(vector-ref server 1) ;; Pid
(vector-ref server 2) ;; Hostname
(conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
- (vector-ref server 5) ;; Pubport
+ (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
+ ;; (vector-ref server 5) ;; Pubport
;; (vector-ref server 10) ;; Last beat
;; (vector-ref server 6) ;; Start time
;; (vector-ref server 7) ;; Priority
;; (vector-ref server 8) ;; State
- (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!)
- "alive"
- "dead")
- (vector-ref server 11) ;; Transport
+ (vector-ref server 8) ;; State
+ (vector-ref server 12) ;; RunId
)))
(for-each (lambda (val)
- ;; (print "rownum: " rownum " colnum: " colnum " val: " val)
- (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val)
- (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
- (set! colnum (+ 1 colnum)))
+ (let* ((row-col (conc rownum ":" colnum))
+ (curr-val (iup:attribute servers-matrix row-col)))
+ (if (not (equal? (conc val) curr-val))
+ (begin
+ (iup:attribute-set! servers-matrix row-col val)
+ (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
+ (set! colnum (+ 1 colnum))))
vals)
(set! rownum (+ rownum 1)))
(iup:attribute-set! servers-matrix "REDRAW" "ALL"))
servers)))))
(set! colnum 0)
@@ -493,39 +495,41 @@
(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
(set! colnum (+ colnum 1)))
colnames)
(set! dashboard:update-servers-table updater)
;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
- (iup:hbox
- (iup:vbox
- (iup:button "Start"
- ;; #:size "50x"
- #:expand "YES"
- #:action (lambda (obj)
- (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- "megatest -server - &")))
- ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- (system cmd))))
- (iup:button "Stop"
- #:expand "YES"
- ;; #:size "50x"
- #:action (lambda (obj)
- (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- "megatest -stop-server 0 &")))
- ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- (system cmd))))
- (iup:button "Restart"
- #:expand "YES"
- ;; #:size "50x"
- #:action (lambda (obj)
- (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- "megatest -stop-server 0;megatest -server - &")))
- ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- (system cmd)))))
- servers-matrix
- )))
-
+ ;; (iup:hbox
+ ;; (iup:vbox
+ ;; (iup:button "Start"
+ ;; ;; #:size "50x"
+ ;; #:expand "YES"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -server - &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd))))
+ ;; (iup:button "Stop"
+ ;; #:expand "YES"
+ ;; ;; #:size "50x"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -stop-server 0 &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd))))
+ ;; (iup:button "Restart"
+ ;; #:expand "YES"
+ ;; ;; #:size "50x"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -stop-server 0;megatest -server - &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd)))))
+ ;; servers-matrix
+ ;; )))
+ servers-matrix
+ ))
+
;; The main menu
(define (dcommon:main-menu)
(iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
(iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
(iup:menu-item "Open" action: (lambda (obj)
Index: docs/html/megatest.html
==================================================================
--- docs/html/megatest.html
+++ docs/html/megatest.html
@@ -2,11 +2,11 @@
-
+
Megatest User Manual
@@ -782,11 +782,11 @@
Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try.