Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,11 +28,11 @@
ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = dbmod.scm
+MSRCFILES = dbmod.scm dbfile.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
@@ -162,11 +162,11 @@
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.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
-db.o api.o : mofiles/dbmod.o
+db.o api.o : mofiles/dbmod.o mofiles/dbfile.o
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -135,11 +135,11 @@
(define *default-log-port* (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *default-area-tag* "local")
;; DATABASE
-(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
+(define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
;; db access
(define *db-last-access* (current-seconds)) ;; last db access, used in server
@@ -979,10 +979,14 @@
"/megatest_localdb/"
tsname
(string-translate *toppath* "/" "."))
))))
(set! *db-cache-path* dbpath)
+ ;; ensure megatest area has .db
+ (let ((dbarea (conc *toppath* "/.db")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
dbpath))
#f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
@@ -1045,11 +1049,11 @@
((dbr:dbstruct-read-only dbstruct)
(debug:print-info 13 *default-log-port* "loading read-only watchdog")
(common:readonly-watchdog dbstruct))
(else
(debug:print-info 13 *default-log-port* "loading writable-watchdog.")
- (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
+ (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "brute-force-sync")))
(cond
((equal? syncer "brute-force-sync")
(server:writable-watchdog-bruteforce dbstruct))
((equal? syncer "delta-sync")
(server:writable-watchdog-deltasync dbstruct))
ADDED configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,75 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit configfmod))
+;; (declare (uses mtargs))
+;; (declare (uses debugprint))
+;; (declare (uses keysmod))
+
+(module configfmod
+*
+
+(import srfi-1
+
+;; scheme
+;;
+;; big-chicken ;; more of a reminder than anything ...
+;; chicken.base
+;; chicken.condition
+;; chicken.file
+;; chicken.io
+;; chicken.pathname
+;; chicken.port
+;; chicken.pretty-print
+;; chicken.process
+;; chicken.process-context
+;; chicken.process-context.posix
+;; chicken.sort
+;; chicken.string
+;; chicken.time
+;; chicken.eval
+;;
+;; debugprint
+;; (prefix mtargs args:)
+;; pkts
+;; keysmod
+;;
+;; (prefix base64 base64:)
+;; (prefix dbi dbi:)
+;; (prefix sqlite3 sqlite3:)
+;; (srfi 18)
+;; directory-utils
+;; format
+;; matchable
+;; md5
+;; message-digest
+;; regex
+;; regex-case
+;; sparse-vectors
+;; srfi-1
+;; srfi-13
+;; srfi-69
+;; stack
+;; typed-records
+;; z3
+
+ )
+)
+
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -29,10 +29,12 @@
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit db))
(declare (uses common))
+(declare (uses dbmod))
+(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
@@ -42,44 +44,21 @@
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
-;;======================================================================
-;; R E C O R D S
-;;======================================================================
-
-;; each db entry is a pair ( db . dbfilepath )
-;; I propose this record evolves into the area record
-;;
-(defstruct dbr:dbstruct
- (tmpdb #f)
- (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
- (mtdb #f)
- (refndb #f)
- (homehost #f) ;; not used yet
- (on-homehost #f) ;; not used yet
- (read-only #f)
- (stmt-cache (make-hash-table))
- ) ;; goal is to converge on one struct for an area but for now it is too confusing
-
+(import dbmod)
+(import dbfile)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
-;;======================================================================
-;; alist-of-alists
-;;======================================================================
-;;
-;; (define (db:aa-set! dat key1 key2 val)
-;; (let loop ((
-
;;======================================================================
;; hash of hashs
;;======================================================================
@@ -127,26 +106,38 @@
(begin
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
+
+(define (db:generic-error-printout exn . message)
+ (print-call-chain (current-error-port))
+ (apply debug:print-error 0 *default-log-port* message)
+ (debug:print-error 0 *default-log-port* ;; " params: " params
+ ", error: " ((condition-property-accessor 'exn 'message) exn)
+ ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
+ ", location: " ((condition-property-accessor 'exn 'location) exn)
+ ))
;; Get/open a database
;; if run-id => get run specific db
;; if #f => get main db
+;; if run-id is a string treat it as a filename
;; 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)
+(define (db:get-db dbstruct run-id)
(if (stack? (dbr:dbstruct-dbstack dbstruct))
(if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
- (let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
+ (let* ((dbname (db:run-id->dbname run-id))
+ (newdb (db:open-megatest-db path: (db:dbfile-path)
+ name: dbname)))
;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
newdb)
(stack-pop! (dbr:dbstruct-dbstack dbstruct)))
- (db:open-db dbstruct)))
+ (db:open-db dbstruct run-id)))
;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
@@ -170,11 +161,11 @@
;; 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* ((have-struct (dbr:dbstruct? dbstruct))
(dbdat (if have-struct
- (db:get-db dbstruct)
+ (db:get-db dbstruct run-id)
#f))
(db (if have-struct
(db:dbdat-get-db dbdat)
dbstruct))
(fname (db:dbdat-get-path dbdat))
@@ -202,33 +193,10 @@
(exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
(exn ()
(db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
((condition-property-accessor 'exn 'message) exn))))))
-;;======================================================================
-;; 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)))b
-;; (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 => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
@@ -315,28 +283,33 @@
)))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
-(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
+(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
(let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
(if (stack? tmpdb-stack)
(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
(let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
(dbpath (db:dbfile-path )) ;; path to tmp db area
+ (dbname (db:run-id->dbname run-id))
(dbexists (common:file-exists? dbpath))
- (tmpdbfname (conc dbpath "/megatest.db"))
+ (mtdbfname (conc *toppath* "/.db/"dbname))
+ (mtdbexists (common:file-exists? mtdbfname))
+ (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f))
+ (mtdb (db:open-megatest-db mtdbfname))
+ ;; the reference db for syncing
+ (refdbfname (conc dbpath "/ref_"dbname))
+ (refndb (db:open-megatest-db refdbfname))
+ ;; (mtdbpath (db:dbdat-get-path mtdb))
+ ;; the tmpdb
+ (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db
+ (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
(dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
- (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
-
- (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f))
- (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
- (mtdb (db:open-megatest-db))
- (mtdbpath (db:dbdat-get-path mtdb))
- (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
- (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
- (write-access (file-write-access? mtdbpath))
+ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
+
+ (write-access (file-write-access? mtdbfname))
;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime
;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))
;(fmt (file-modification-time tmpdbfname))
@@ -344,12 +317,12 @@
(when write-access
(sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
(sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))
- ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
- ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
+ ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
+ ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
(if (and dbexists (not write-access))
(begin
(set! *db-write-access* #f)
(dbr:dbstruct-read-only-set! dbstruct #t)))
(dbr:dbstruct-mtdb-set! dbstruct mtdb)
@@ -362,12 +335,12 @@
(> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
(debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
- ;touch tmp db to avoid wal mode wierdness
- (set! (file-modification-time tmpdbfname) (current-seconds))
+ ;; touch tmp db to avoid wal mode wierdness
+ (set! (file-modification-time tmpdbfname) (current-seconds))
(debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
)
(debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
@@ -383,31 +356,38 @@
(set! last-update-time lup))
db
"select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);")
last-update-time))
;))
+
+;; set up a single db (e.g. main.db, 1.db ... etc.)
+;;
+(define (db:setup-db dbstructs run-id)
+ (let* ((dbname (db:run-id->dbname run-id))
+ (dbstruct (or (hash-table-ref/default dbstructs dbname #f)
+ (make-dbr:dbstruct))))
+ (db:open-db dbstruct run-id areapath: areapath do-sync: do-sync)
+ (hash-table-set! dbstructs dbname dbstruct)
+ dbstruct))
+
;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access.
;;
(define (db:setup do-sync #!key (areapath #f))
;;
(cond
- (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
+ (*dbstruct-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard
(else ;;(common:on-homehost?)
- (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
- (let* ((dbstruct (make-dbr:dbstruct)))
+ (let* ((dbstructs (make-hash-table)))
(when (not *toppath*)
(debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
(launch:setup areapath: areapath))
- (debug:print-info 13 *default-log-port* "Begin db:open-db")
- (db:open-db dbstruct areapath: areapath do-sync: do-sync)
- (debug:print-info 13 *default-log-port* "Done db:open-db")
- (set! *dbstruct-db* dbstruct)
+ (set! *dbstruct-dbs* dbstructs)
;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
- dbstruct))))
+ dbstructs))))
;; (else
;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
;; (exit 1))))
;; Open the classic megatest.db file (defaults to open in toppath)
@@ -415,19 +395,15 @@
;; NOTE: returns a dbdat not a dbstruct!
;;
;;(define (db:reopen-megatest-db
-(define (db:open-megatest-db #!key (path #f)(name #f))
- (let* ((dbdir (or path *toppath*))
- (dbpath (conc dbdir "/" (or name "megatest.db")))
- (dbexists (common:file-exists? dbpath))
+(define (db:open-megatest-db dbpath)
+ (let* ((dbexists (common:file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
- (db:initialize-main-db db)
- ;;(db:initialize-run-id-db db)
- )))
+ (db:initialize-main-db db))))
(write-access (file-write-access? dbpath)))
(debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
(cons db dbpath)))
@@ -1135,12 +1111,20 @@
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
options)
data-synced))
-(define (db:tmp->megatest.db-sync dbstruct last-update)
- (let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
+;; Sync all changed db's
+;;
+(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
+ (let* ((dbname (db:run-id->dbname run-id))
+ (mtdb (dbr:dbstruct-mtdb dbstruct))
+
+
+ ;; more to do here?
+
+
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
res))
ADDED dbfile.scm
Index: dbfile.scm
==================================================================
--- /dev/null
+++ dbfile.scm
@@ -0,0 +1,89 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit dbfile))
+
+(module dbfile
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:)
+ posix typed-records srfi-18
+ srfi-69)
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; each db entry is a pair ( db . dbfilepath )
+;; NOTE: Need one dbr:dbstruct per main.db, 1.db ...
+;;
+(defstruct dbr:dbstruct
+ (dbname #f)
+ (dbdats (make-hash-table)) ;; id => dbdat
+ ;; (tmpdbs #f)
+ ;; (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
+ ;; (mtdb #f)
+ ;; (refndb #f)
+ (homehost #f) ;; not used yet
+ (on-homehost #f) ;; not used yet
+ (read-only #f)
+ ;; (stmt-cache (make-hash-table))
+ ) ;; goal is to converge on one struct for an area but for now it is too confusing
+
+(defstruct dbr:dbdat
+ (db #f) ;; should rename this to oddb for on disk db
+ (tmpdb #f)
+ (dbhstack #f) ;; do not init with a stack
+ (last-sync 0)
+ (last-write (current-seconds))
+ (run-id #f)
+ (fname #f))
+
+; Returns the dbdat for a particular dbfile inside the area
+;;
+(define (dbr:dbstruct-get-dbdat dbstruct dbfile)
+ (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))
+
+(define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
+ (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))
+
+(define (db:run-id->first-num run-id)
+ (let* ((s (number->string run-id))
+ (l (string-length s)))
+ (substring s (- l 1) l)))
+
+;; 1234 => 4/1234.db
+;; #f => 0/main.db
+;; (abandoned the idea of num/db)
+;;
+(define (db:run-id->path apath run-id)
+ (conc apath"/"(db:run-id->dbname run-id)))
+
+(define (db:dbname->path apath dbname)
+ (conc apath"/"dbname))
+
+(define (db:run-id->dbname run-id)
+ (cond
+ ((number? run-id) (conc ".db/" (modulo run-id 100) ".db"))
+ ((not run-id) (conc ".db/main.db"))
+ (else run-id)))
+
+)
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -18,6 +18,6 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
;; (declare (unit megatest-version))
-(define megatest-version 1.6589)
+(define megatest-version 1.7001)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -39,12 +39,17 @@
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
+(declare (uses dbmod))
+(declare (uses dbmod.import))
+
;; (declare (uses ftail))
;; (import ftail)
+
+(import dbmod)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
ADDED tests/simplerun/Makefile
Index: tests/simplerun/Makefile
==================================================================
--- /dev/null
+++ tests/simplerun/Makefile
@@ -0,0 +1,5 @@
+
+cleanup :
+ killall mtest dboard -v -9 || true
+ rm -rf *.log *.bak NB* logs/* .meta .db ../simpleruns/* lt
+
ADDED tests/simplerun/debug.scm
Index: tests/simplerun/debug.scm
==================================================================
--- /dev/null
+++ tests/simplerun/debug.scm
@@ -0,0 +1,61 @@
+
+(module junk
+ *
+
+(import big-chicken
+ rmtmod
+ apimod
+ dbmod
+ srfi-18
+ trace)
+
+(trace-call-sites #t)
+(trace
+ ;; db:get-tests-for-run
+ ;; rmt:general-open-connection
+ ;; rmt:open-main-connection
+ ;; rmt:drop-conn
+ ;; rmt:send-receive
+ ;; rmt:log-to-main
+ )
+
+(define (make-run-id)
+ (let* ((s (conc (current-process-id)))
+ (l (string-length s)))
+ (string->number (substring s (- l 3) l))
+ ))
+
+(define (run)
+ (let* ((th1 (make-thread
+ (lambda ()
+ (let loop ((r 0)
+ (i 1)
+ (s 0)) ;; sum
+ (let ((start-time (current-milliseconds))
+ (run-id (+ r (make-run-id))))
+ (rmt:register-test run-id "test1" (conc "item_" i))
+ (thread-sleep! 0.01)
+ (let* ((qry-time (- (current-milliseconds) start-time))
+ (tot-query-time (+ qry-time s))
+ (avg-query-time (* 1.0 (/ tot-query-time (max i 1)))))
+ (if (> qry-time 500)
+ (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time))
+ (if (eq? (modulo i 100) 0)
+ (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time))
+ (if (< i 500)
+ (loop r (+ i 1) tot-query-time)
+ (if (< r 100)
+ (let* ((start-time (current-milliseconds)))
+ (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time))
+ ;; run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode
+ (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f 0 #f))" tests for run "run-id)
+ (print "Average query time: "avg-query-time)
+ (loop (+ r 1) 0 tot-query-time))))))))
+ )))
+ (thread-start! th1)
+ (thread-join! th1)))
+
+(run)
+)
+
+
Index: tests/simplerun/megatest.config
==================================================================
--- tests/simplerun/megatest.config
+++ tests/simplerun/megatest.config
@@ -21,10 +21,12 @@
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50
+[server]
+timeout 3600
# Uncomment this to make the in-mem db into a disk based db (slower but good for debug)
# be aware that some unit tests will fail with this due to persistent data
#
# tmpdb /tmp
@@ -35,15 +37,15 @@
[validvalues]
state start end completed
# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
-useshell yes
-launcher nbfind
+# useshell yes
+launcher nbfake
# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value
# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns
Index: tests/simplerun/tests/test1/testconfig
==================================================================
--- tests/simplerun/tests/test1/testconfig
+++ tests/simplerun/tests/test1/testconfig
@@ -24,11 +24,11 @@
[requirements]
# waiton setup
priority 0
# Iteration for your tests are controlled by the items section
-[items]
+# [items]
# PARTOFDAY morning noon afternoon evening night
# test_meta is a section for storing additional data on your test
[test_meta]
author matt