Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -29,10 +29,11 @@
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit db))
(declare (uses common))
+(declare (uses dbmod))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
@@ -41,10 +42,12 @@
(include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
+
+(import dbmod)
;;======================================================================
;; R E C O R D S
;;======================================================================
@@ -135,18 +138,20 @@
;; 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)
+(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 +175,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))
@@ -315,11 +320,11 @@
)))
;; 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
@@ -327,11 +332,26 @@
(tmpdbfname (conc dbpath "/megatest.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))
+ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
+
+
+
+
+
+
+
+ FIXME!!!
+
+
+
+
+
+
+
(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))
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)
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