Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -63,15 +63,15 @@
mofiles/archivemod.o : mofiles/launchmod.o
mofiles/archivemod.o : mofiles/servermod.o
mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
-# mofiles/clientmod.o : mofiles/servermod.o
+# mofiles/clientmod.o : mofiles/servermod.oibpq-dev
+mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o
mofiles/commonmod.o : mofiles/hostinfo.o
-mofiles/commonmod.o : mofiles/itemsmod.o
mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/keysmod.o
@@ -80,10 +80,11 @@
mofiles/dbmod.o : mofiles/csv-xml.o
mofiles/dbmod.o : mofiles/keysmod.o
mofiles/dbmod.o : mofiles/mtmod.o
mofiles/ezstepsmod.o : mofiles/rmtmod.o
mofiles/ezstepsmod.o : mofiles/subrunmod.o
+mofiles/itemsmod.o : mofiles/commonmod.o
mofiles/keysmod.o : mofiles/debugprint.o
mofiles/launchmod.o : mofiles/bigmod.o
mofiles/launchmod.o : mofiles/ezstepsmod.o
mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o
mofiles/mtmod.o : mofiles/debugprint.o
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -81,11 +81,10 @@
get-run-state
get-run-stats
get-run-times
get-targets
get-target
- ;; register-run
get-tests-tags
get-test-times
get-tests-for-run
get-tests-for-run-state-status
get-test-id
@@ -200,10 +199,12 @@
;; SERVERS
;; ((start-server) (apply server:kind-run params))
((kill-server) (set! *server-run* #f))
((get-server) (api:start-server dbstruct params))
((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath)
+ ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath)
+ ((get-count-servers) (apply db:get-count-servers dbstruct params))
;; TESTS
;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
@@ -229,10 +230,11 @@
((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
;; RUNS
((register-run) (apply db:register-run dbstruct params))
+ ((insert-run) (apply db:insert-run dbstruct params))
((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
@@ -356,11 +358,11 @@
((have-incompletes?) (apply db:have-incompletes? dbstruct params))
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
- (db:general-call dbstruct stmtname realparams)))
+ (db:general-call dbstruct stmtname run-id realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
@@ -409,21 +411,22 @@
(define (api:process-request dbstruct indat) ;; the $ is the request vars proc
(let* ((cmd-in (alist-ref 'cmd indat)) ;; ($ 'cmd))
(cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in))
(params (alist-ref 'params indat))
(key (alist-ref 'key indat)) ;; TODO - add this back
+ (doprint (apply common:low-noise-print 10 params))
)
- (debug:print 0 *default-log-port* "cmd:" cmd " with params " params ", key " key)
+ (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key))
(case cmd-in
((ping) #t)
;; ((quit) (exit))
(else
(if (equal? key *my-signature*) ;; TODO - get real key involved
(begin
(set! *api-process-request-count* (+ *api-process-request-count* 1))
(let* ((res (api:execute-requests dbstruct cmd params)))
- (debug:print 0 *default-log-port* "res:" res)
+ (if doprint (debug:print 0 *default-log-port* "res:" res))
#;(if (not success)
(debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
(if (> *api-process-request-count* *max-api-process-requests*)
(set! *max-api-process-requests* *api-process-request-count*))
(set! *api-process-request-count* (- *api-process-request-count* 1))
Index: archivemod.scm
==================================================================
--- archivemod.scm
+++ archivemod.scm
@@ -223,11 +223,11 @@
(if s (string->symbol s) 'bup)))
(archiver-cmd (case archiver
((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
(else #f)))
- (src-archive-linktree (rmt:get-var "src-archive-linktree"))
+ (src-archive-linktree (rmt:get-var run-id "src-archive-linktree"))
(print-prefix "Running: ") ;; change to #f to turn off printing
(preclean-spec (configf:get-section *configdat* "archive-preclean")))
(if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))
(rmt:set-var "src-archive-linktree" linktree))
@@ -481,11 +481,11 @@
'old2new
)
(debug:print-info 1 *default-log-port* "dropping triggers to update linktree")
(rmt:drop-all-triggers)
(let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- (src-archive-linktree (rmt:get-var "src-archive-linktree")))
+ (src-archive-linktree (rmt:get-var #f "src-archive-linktree")))
(if (not (equal? src-archive-linktree linktree))
(rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
(debug:print-info 1 *default-log-port* "creating triggers after updating linktree")
(rmt:create-all-triggers)
))
ADDED build-assist/ck5-eggs.list
Index: build-assist/ck5-eggs.list
==================================================================
--- /dev/null
+++ build-assist/ck5-eggs.list
@@ -0,0 +1,43 @@
+address-info
+ansi-escape-sequences
+apropos
+base64
+crypt
+csv-abnf
+directory-utils
+filepath
+fmt
+format
+http-client
+itemsmod
+json
+linenoise
+md5
+message-digest
+nanomsg
+postgresql
+queues
+regex
+regex-case
+rfc3339
+s11n
+sha1
+slice
+sparse-vectors
+spiffy
+spiffy-directory-listing
+spiffy-request-vars
+sql-de-lite
+sqlite3
+sql-null
+srfi-1
+srfi-13
+srfi-19
+sxml-modifications
+sxml-serializer
+sxml-transforms
+system-information
+test
+typed-records
+uri-common
+z3
ADDED build-assist/debian-packages-needed
Index: build-assist/debian-packages-needed
==================================================================
--- /dev/null
+++ build-assist/debian-packages-needed
@@ -0,0 +1,5 @@
+build-essential
+libnanomsg-dev
+libpq-dev
+libsqlite3-dev
+sqlite3
ADDED build-assist/iup-compile.sh
Index: build-assist/iup-compile.sh
==================================================================
--- /dev/null
+++ build-assist/iup-compile.sh
@@ -0,0 +1,19 @@
+if [[ -z $PREFIX ]];then
+ echo "PREFIX required"
+ exit
+fi
+
+echo "Put iup, im and cd .a and .so files in PREFIX/lib"
+echo " 1. get opensrc fossil from https://www.kiatoa.com/fossils/opensrc"
+echo " 2. list the unversioned files and export the cd, im and iup lib for your kernel (try uname -a for the kernel number) 4.15 ==> 415_64"
+echo " 3. untar iup, im and cp tars into a clean working dir and then copy:"
+echo " cp *.a *.so $PREFIX/lib"
+echo " cp include/*.h $PREFIX/include"
+echo " 4. run the chicken-install like this:"
+
+echo "If you use a wrapper (e.g. ck5) to create the chicken environment:"
+echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup"
+echo "else:"
+echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" chicken-install iup"
+echo "Then repeat for canvas-draw"
+
DELETED common.scm
Index: common.scm
==================================================================
--- common.scm
+++ /dev/null
@@ -1,46 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2012, 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 .
-
-;;======================================================================
-
-;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:)
-;; format dot-locking csv-xml z3 udp ;; sql-de-lite
-;; hostinfo md5 message-digest typed-records directory-utils stack
-;; matchable regex posix (srfi 18) extras ;; tcp
-;; (prefix nanomsg nmsg:)
-;; (prefix sqlite3 sqlite3:)
-;; pkts (prefix dbi dbi:)
-;; )
-;;
-;; (declare (unit common))
-;; ;; (declare (uses commonmod))
-;; ;; (import commonmod)
-;;
-;; (include "common_records.scm")
-
-
-;; (require-library margs)
-;; (include "margs.scm")
-
-;; (define old-exit exit)
-;;
-;; (define (exit . code)
-;; (if (null? code)
-;; (old-exit)
-;; (old-exit code)))
-
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -28,11 +28,11 @@
(declare (uses configfmod))
(declare (uses hostinfo))
(declare (uses keysmod))
;; odd but it works?
-(declare (uses itemsmod))
+;; (declare (uses itemsmod))
(module commonmod
*
(import scheme
@@ -78,11 +78,11 @@
pkts
processmod
(prefix mtargs args:)
configfmod
keysmod
- itemsmod
+ ;; itemsmod
hostinfo
)
;;======================================================================
;; CONTENTS
@@ -108,12 +108,12 @@
(define *bdat* #f) ;; the one and only (someday) global?
(defstruct bdat
- (home (getenv "HOME"))
- (user (getenv "USER"))
+ (home (get-environment-variable "HOME"))
+ (user (get-environment-variable "USER"))
(watchdog #f)
(time-to-exit #f)
(task-db #f)
(target #f)
(this-exe-fullpath #f)
@@ -153,12 +153,12 @@
(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z!
bdat))
-;; (define home (getenv "HOME"))
-;; (define user (getenv "USER"))
+;; (define home (get-environment-variable "HOME"))
+;; (define user (get-environment-variable "USER"))
(define keys:config-get-fields common:get-fields)
;; Globals
;;
;;(define *server-loop-heart-beat* (current-seconds))
@@ -171,11 +171,11 @@
(define *db-keys* #f)
(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
-;; (define *configdat* #f) ;; megatest.config data ==> moved to configfmod
+(define *configdat* #f) ;; megatest.config data ==> moved to configfmod
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
(define *test-meta-updated* (make-hash-table))
@@ -228,17 +228,15 @@
(define *heartbeat-mutex* (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded* #f)
(define *writes-total-delay* 0)
+(define *unclean-shutdown* #t) ;; flag to clear on clean shutdown
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
-;; RPC transport
-(define *rpc:listener* #f)
-
;; KEY info
;; (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
@@ -408,20 +406,20 @@
(dynamic-wind
(lambda () (void))
(lambda ()
;; (use posix)
(for-each (lambda (var-value)
- (setenv (car var-value) (cdr var-value)))
+ (set-environment-variable! (car var-value) (cdr var-value)))
variables)
(thunk))
(lambda ()
(for-each (lambda (var-value)
(let ((var (car var-value))
(value (cdr var-value)))
(if value
- (setenv var value)
- (unsetenv var))))
+ (set-environment-variable! var value)
+ (unset-environment-variable! var))))
pre-existing-variables)))))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
@@ -902,11 +900,11 @@
(hash-table-set! *common:denoise* key currtime)
#t)
#f)))
(define (common:get-megatest-exe)
- (or (getenv "MT_MEGATEST") "megatest"))
+ (or (get-environment-variable "MT_MEGATEST") "megatest"))
(define (common:read-encoded-string instr)
(handle-exceptions
exn
(handle-exceptions
@@ -991,11 +989,11 @@
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-area-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
- (getenv "MT_TESTSUITE_NAME")
+ (get-environment-variable "MT_TESTSUITE_NAME")
(pathname-file (or (if (string? *toppath* )
(pathname-file *toppath*)
#f)
(common:get-toppath #f)))
"please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
@@ -1005,16 +1003,16 @@
(define (common:get-toppath areapath)
(or *toppath*
(if areapath
(begin
(set! *toppath* areapath)
- (setenv "MT_RUN_AREA_HOME" areapath)
+ (set-environment-variable! "MT_RUN_AREA_HOME" areapath)
areapath)
#f)
- (if (getenv "MT_RUN_AREA_HOME")
+ (if (get-environment-variable "MT_RUN_AREA_HOME")
(begin
- (set! *toppath* (getenv "MT_RUN_AREA_HOME"))
+ (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
*toppath*)
#f)
;; last resort, look for megatest.config
(let loop ((thepath (realpath ".")))
(if (file-exists? (conc thepath "/megatest.config"))
@@ -1255,36 +1253,27 @@
(filter (lambda (x)
(patt-list-match x target-patt))
targs)
targs)))
-;;======================================================================
-;; Lookup a value in runconfigs based on -reqtarg or -target
-;;
-(define (runconfigs-get config var)
- (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
- (if targ
- (or (configf:lookup config targ var)
- (configf:lookup config "default" var))
- (configf:lookup config "default" var))))
-
(define (common:args-get-state)
(or (args:get-arg "-state")(args:get-arg ":state")))
(define (common:args-get-status)
(or (args:get-arg "-status")(args:get-arg ":status")))
(define (common:args-get-testpatt rconf)
- (let* (;; (tagexpr (args:get-arg "-tagexpr"))
+ (let* ((target (common:args-get-target))
+ ;; (tagexpr (args:get-arg "-tagexpr"))
;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
(testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
- (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
+ (rtestpatt (if rconf (runconfigs-get rconf target testpatt-key) #f)))
(cond
((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
- (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
+ (let* ((patts-from-mode-patt (runconfigs-get rconf target testpatt-key)))
(debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
patts-from-mode-patt)
(begin
(debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt)
#f))) ;; We do NOT fall back to "%"
@@ -1334,35 +1323,35 @@
(file-writable? path-string))
path-string
#f)))
(define (common:get-linktree)
- (or (getenv "MT_LINKTREE")
+ (or (get-environment-variable "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
#f)
- (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
- (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
+ (if (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
+ (conc (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) "/lt")
#f)
(let* ((tp (common:get-toppath #f))
(lt (conc tp "/lt")))
(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
lt)))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
- (getenv "MT_RUNNAME"))))
- ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
+ (get-environment-variable "MT_RUNNAME"))))
+ ;; (if res (set-environment-variable! "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
- (getenv "MT_TARGET")))
+ (get-environment-variable "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
@@ -1381,15 +1370,15 @@
;;======================================================================
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
- (if (getenv "MT_TEST_NAME")
- (if (and (getenv "MT_ITEMPATH")
- (not (equal? (getenv "MT_ITEMPATH") "")))
- (getenv "MT_TEST_NAME")
- (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
+ (if (get-environment-variable "MT_TEST_NAME")
+ (if (and (get-environment-variable "MT_ITEMPATH")
+ (not (equal? (get-environment-variable "MT_ITEMPATH") "")))
+ (get-environment-variable "MT_TEST_NAME")
+ (conc (get-environment-variable "MT_TEST_NAME") "/" (get-environment-variable "MT_ITEMPATH")))
#f))
;;======================================================================
;; do we honor the caches of the config files?
;;
@@ -1399,14 +1388,14 @@
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
(set! res #f)
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
(set! res #t))))
(if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
- (if (getenv "MT_USE_CACHE")
- (if (equal? (getenv "MT_USE_CACHE") "yes")
+ (if (get-environment-variable "MT_USE_CACHE")
+ (if (equal? (get-environment-variable "MT_USE_CACHE") "yes")
(set! res #t)
- (if (equal? (getenv "MT_USE_CACHE") "no")
+ (if (equal? (get-environment-variable "MT_USE_CACHE") "no")
(set! res #f)))) ;; overrides -no-cache switch
res))
;;======================================================================
;; force use of server?
@@ -2061,27 +2050,27 @@
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
(debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
- (setenv "TARGETHOST" hostname)
+ (set-environment-variable! "TARGETHOST" hostname)
(let* ((logdir (if (directory-exists? "logs")
"logs/"
""))
(logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
(gzfile (if logfile (conc logfile ".gz"))))
- (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
+ (set-environment-variable! "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
(system (conc "nbfake kill "kill-switch" "pid))
(when logfile
(thread-sleep! 0.5)
(if (file-exists? gzfile) (delete-file gzfile))
(system (conc "gzip " logfile))
- (unsetenv "TARGETHOST_LOGF")
- (unsetenv "TARGETHOST"))))
+ (unset-environment-variable! "TARGETHOST_LOGF")
+ (unset-environment-variable! "TARGETHOST"))))
(define (server:get-logs-list area-path)
(let* (;; (server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log"))
;; (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string))))
(server-logs (glob (conc area-path"/logs/server-*-*.log")))
@@ -2713,11 +2702,11 @@
(val (cadr p))
(prv (get-environment-variable var)))
(set! res (cons (list var prv) res))
(if val
(safe-setenv var (->string val))
- (unsetenv var))))
+ (unset-environment-variable! var))))
lst)
res)
'()))
;;======================================================================
@@ -2737,17 +2726,17 @@
x))
envvars))))
(define (common:with-orig-env proc)
(let ((current-env (get-environment-variables)))
- (for-each (lambda (x) (unsetenv (car x))) current-env)
- (for-each (lambda (x) (setenv (car x) (cdr x))) (bdat-orig-env *bdat*))
+ (for-each (lambda (x) (unset-environment-variable! (car x))) current-env)
+ (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) (bdat-orig-env *bdat*))
(let ((rv (cond
((string? proc)(system proc))
(proc (proc)))))
- (for-each (lambda (x) (unsetenv (car x))) (bdat-orig-env *bdat*))
- (for-each (lambda (x) (setenv (car x) (cdr x))) current-env)
+ (for-each (lambda (x) (unset-environment-variable! (car x))) (bdat-orig-env *bdat*))
+ (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) current-env)
rv)))
(define (common:without-vars proc . var-patts)
(let ((vars (make-hash-table)))
(for-each
@@ -2756,20 +2745,20 @@
(lambda (var-patt)
(if (string-match var-patt (car vardat))
(let ((var (car vardat))
(val (cdr vardat)))
(hash-table-set! vars var val)
- (unsetenv var))))
+ (unset-environment-variable! var))))
var-patts))
(get-environment-variables))
(cond
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
- (setenv var val)))
+ (set-environment-variable! var val)))
vars))
(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
(let* ((pre-cmd (dtests:get-pre-command))
(post-cmd (dtests:get-post-command))
@@ -3576,38 +3565,10 @@
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
-;; return items given config
-;;
-(define (tests:get-items tconfig)
- (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
- (itemstable (hash-table-ref/default tconfig "itemstable" #f)))
- ;; if either items or items table is a proc return it so test running
- ;; process can know to call items:get-items-from-config
- ;; if either is a list and none is a proc go ahead and call get-items
- ;; otherwise return #f - this is not an iterated test
- (cond
- ((procedure? items)
- (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
- items) ;; calc later
- ((procedure? itemstable)
- (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
- itemstable) ;; calc later
- ((filter (lambda (x)
- (let ((val (car x)))
- (if (procedure? val) val #f)))
- (append (if (list? items) items '())
- (if (list? itemstable) itemstable '())))
- 'have-procedure)
- ((or (list? items)(list? itemstable)) ;; calc now
- (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
- " items: " items " itemstable: " itemstable)
- (items:get-items-from-config tconfig))
- (else #f)))) ;; not iterated
-
(define (tests:get-tests-search-path cfgdat)
(let ((paths (let ((section (if cfgdat
(configf:get-section cfgdat "tests-paths")
#f)))
(if section
@@ -3649,11 +3610,11 @@
(define (server:expiration-timeout)
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
(common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
(* 3600 (string->number tmo))
- 600))) ;; default is ten minutes
+ 60))) ;; default is one minute
(define (runs:get-mt-env-alist run-id runname target testname itempath)
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
`(("MT_TEST_NAME" . ,testname)
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -22,11 +22,41 @@
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses keysmod))
(module configfmod
- *
+ (
+ common:get-fields
+ common:nice-path
+ common:read-link-f
+ common:with-env-vars
+ configf:config->ini
+ configf:alist->config
+ configf:assoc-safe-add
+ configf:config->alist
+ configf:find-and-read-config
+ configf:get-section
+ configf:lookup
+ configf:lookup-number
+ configf:map-all-hier-alist
+ configf:read-alist
+ configf:read-config
+ configf:read-refdb
+ configf:section-var-set!
+ configf:section-vars
+ configf:set-section-var
+ configf:var-is?
+ configf:write-alist
+ configf:write-config
+ find-config
+ nice-path
+ process:cmd-run->list
+ runconfig:read
+ runconfigs-get
+ safe-setenv
+ configf:eval-string-in-environment
+ )
(import scheme
chicken.base
chicken.condition
@@ -35,10 +65,11 @@
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
+ chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.eval
@@ -66,12 +97,10 @@
typed-records
z3
)
-(define *configdat* #f)
-
(define getenv get-environment-variable)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)
;;======================================================================
@@ -953,14 +982,81 @@
;;======================================================================
;; Config file handling
;;======================================================================
;; convert to param?
-(define configf:std-imports "") ;;(import configfmod commonmod)")
-
+(define configf:std-imports "(import configfmod commonmod)")
+(define (configf:process-one matchdat l ht allow-system env-to-use linenum)
+ (let* ((prestr (list-ref matchdat 1))
+ (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+ (cmd (list-ref matchdat 3))
+ (quotedcmd (conc "\""cmd"\""))
+ (poststr (list-ref matchdat 4))
+ (result #f)
+ (start-time (current-seconds))
+ (cmdsym (string->symbol cmdtype))
+ (fullcmd
+ (if (member cmdsym '(scheme scm))
+ `(eval-needed
+ ,(conc configf:std-imports
+ "(import chicken.process-context.posix chicken.process-context)"
+ "(define setenv set-environment-variable)"
+ (conc "(lambda (ht)" cmd ")")))
+ (case cmdsym
+ ((system) `(noeval-needed ,(conc (configf:system ht quotedcmd))))
+ ((shell sh) `(noeval-needed ,(conc (string-translate (shell quotedcmd) "\n" " "))))
+ ((realpath rp)`(noeval-needed ,(conc (common:nice-path quotedcmd))))
+ ((getenv gv) `(noeval-needed ,(conc (get-environment-variable cmd))))
+ ;; ((mtrah) (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))))
+ ((get g)
+ (match
+ (string-split cmd)
+ ((sect var)(configf:lookup ht sect var))
+ (else
+ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
+ '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
+ ((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ (else `(#f ,(conc "cmd: " cmd " not recognised")))))))
+ (match
+ fullcmd
+ (('eval-needed newres)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", fullcmd="fullcmd", exn=" exn)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (print "exn=" (condition->list exn))
+ (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
+ (if (or allow-system
+ (not (member cmdtype '("system" "shell" "sh"))))
+ (with-input-from-string newres
+ (lambda ()
+ (set! result (if env-to-use
+ ((eval (read) env-to-use) ht)
+ ((eval (read)) ht)
+ ))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}")))))
+ (('noeval-needed newres)(set! result newres))
+ ((#f errres)
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\".")))
+ ;; we process as a result
+ (let ((delta (- (current-seconds) start-time)))
+ (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))
+ (conc prestr result poststr)))
+
(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
(let loop ((res l))
+ (if (string? res)
+ (let ((matchdat (string-search configf:var-expand-regex res)))
+ (if matchdat
+ (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum)))
+ (loop result))
+ res))
+ res)))
+
+(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f))
+ (let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
(if matchdat
(let* ((prestr (list-ref matchdat 1))
(cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
@@ -969,10 +1065,12 @@
(result #f)
(start-time (current-seconds))
(cmdsym (string->symbol cmdtype))
(fullcmd
(conc configf:std-imports
+ "(import chicken.process-context.posix)"
+ "(define setenv set-environment-variable)"
(case cmdsym
((scheme scm) (conc "(lambda (ht)" cmd ")"))
((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
@@ -1016,11 +1114,21 @@
(debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
(loop (conc prestr result poststr)))
res))
res)))
-
+;;======================================================================
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;;
+(define (runconfigs-get config target var)
+ (let ((targ target #;(common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+ (if targ
+ (or (configf:lookup config targ var)
+ (configf:lookup config "default" var))
+ (configf:lookup config "default" var))))
+
+
;; pathenvvar will set the named var to the path of the config
(define (configf:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(env-to-use #f))
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
(toppath (car configinfo))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -18,25 +18,26 @@
;;
;;======================================================================
(use format)
+(declare (uses ducttape-lib))
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
-(import canvas-draw-iup)
-(use ducttape-lib)
+(import canvas-draw)
+;; (import canvas-draw-iup)
+(import ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
-(declare (uses common))
-(declare (uses margs))
-(declare (uses keys))
-(declare (uses items))
-(declare (uses db))
-(declare (uses configf))
+(declare (uses commonmod))
+(declare (uses mtargs))
+;; (declare (uses keys))
+(declare (uses itemsmod))
+(declare (uses dbmod))
+(declare (uses configfmod))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
@@ -45,18 +46,26 @@
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))
+(declare (uses mtver))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
-(include "megatest-version.scm")
+;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
+
+(import commonmod
+ mtargs
+ itemsmod
+ dbmod
+ configfmod
+ )
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2017
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -102,17 +102,17 @@
(last-sync 0)
(last-write (current-seconds))
(run-id #f)
(fname #f))
-;; Returns the dbdat for a particular run-id from dbstruct
+;; Returns the dbdat for a particular dbfile inside the area
;;
-(define (dbr:dbstruct-get-dbdat v run-id)
- (hash-table-ref/default (dbr:dbstruct-dbdats v) run-id #f))
+(define (dbr:dbstruct-get-dbdat dbstruct dbfile)
+ (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))
-(define (dbr:dbstruct-dbdat-put! v run-id db)
- (hash-table-set! (dbr:dbstruct-dbdats v) run-id db))
+(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)))
@@ -155,15 +155,14 @@
;; 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-dbdat dbstruct apath dbfile)
- (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id)))
+ (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile)))
(if dbdat
dbdat
- (let* (;; (dbfile (db:run-id->path apath run-id))
- (newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
+ (let* ((newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
(dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat)
newdbdat))))
;; get the inmem db for actual db operations
;;
@@ -178,21 +177,33 @@
;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;;
(define (db:open-dbdat apath dbfile dbinit-proc)
- (let* (;; (dbfile (db:run-id->path apath run-id))
- (db (db:open-run-db dbfile dbinit-proc))
- (inmem (db:open-inmem-db dbinit-proc))
+ (let* ((db (db:open-run-db dbfile dbinit-proc))
+ ;; (inmem (db:open-inmem-db dbinit-proc))
(dbdat (make-dbr:dbdat
- db: db
- inmem: inmem
+ db: #f ;; db
+ inmem: db ;; inmem
;; run-id: run-id ;; no can do, there are many run-id values that point to single db
fname: dbfile)))
;; now sync the disk file data into the inmemory db
- (db:sync-tables (db:sync-all-tables-list) #f db inmem)
+ ;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
+ ;; (sqlite3:finalize! db) ;; open and close every sync
dbdat))
+;; (define (db:open-dbdat apath dbfile dbinit-proc)
+;; (let* ((db (db:open-run-db dbfile dbinit-proc))
+;; (inmem (db:open-inmem-db dbinit-proc))
+;; (dbdat (make-dbr:dbdat
+;; db: #f ;; db
+;; inmem: inmem
+;; ;; run-id: run-id ;; no can do, there are many run-id values that point to single db
+;; fname: dbfile)))
+;; ;; now sync the disk file data into the inmemory db
+;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
+;; (sqlite3:finalize! db) ;; open and close every sync
+;; dbdat))
;; open the disk database file
;; NOTE: May need to add locking to file create process here
;; returns an sqlite3 database handle
;;
@@ -202,11 +213,11 @@
(create-directory parent-dir #t))
(let* ((exists (file-exists? dbfile))
(db (sqlite3:open-database dbfile))
(handler (sqlite3:make-busy-timeout 3600)))
(sqlite3:set-busy-handler! db handler)
- (db:set-sync db)
+ ;; (db:set-sync db) ;; we don't mind that this is slow?
(if (not exists)
(dbinit-proc db))
db)))
;; open and initialize the inmem db
@@ -216,10 +227,25 @@
(let* ((db (sqlite3:open-database ":memory:"))
(handler (sqlite3:make-busy-timeout 3600)))
(sqlite3:set-busy-handler! db handler)
(dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db)
db))
+
+;; ;; for debugging we have a local mode. these routines support that mode
+;; (define *dbcache* (make-hash-table))
+;;
+;; (define (db:cache-get-dbstruct rid apath)
+;; (let* ((dbname (db:run-id->dbname rid))
+;; (dbfile (db:dbname->path apath dbname)))
+;; (or (hash-table-ref/default *dbcache* dbfile #f)
+;; (let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db)))
+;; (hash-table-set! *dbcache* dbfile dbstruct)
+;; dbstruct))))
+;;
+;; (define (db:finalize-all-cache-dbstruct)
+;; #f)
+;;
;; get and initalize dbstruct for a given run-id
;;
;; - uses db:initialize-db to create the schema
;;
@@ -226,14 +252,13 @@
;; Make the dbstruct, call for main db at least once
;; sync disk db to inmem
;;
;; called in http-transport and replicated in rmt.scm for *local* access.
;;
-(define (db:setup run-id)
+(define (db:setup db-file) ;; run-id)
(assert *toppath* "FATAL: db:setup called before toppath is available.")
- (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))
- (db-file (db:run-id->path *toppath* run-id)))
+ (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))))
(db:get-dbdat dbstruct *toppath* db-file)
(if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
dbstruct))
;;======================================================================
@@ -252,11 +277,11 @@
(db:get-iam-server-lock dbh dbfile))))
(define (db:with-lock-db dbfile proc)
(let* ((dbh (db:open-run-db dbfile db:initialize-db))
(res (proc dbh dbfile)))
- (sqlite3:finalize! dbh)
+ ;; (sqlite3:finalize! dbh)
res))
;; called before db is open?
;;
(define (db:get-iam-server-lock dbh dbfname)
@@ -415,29 +440,33 @@
;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f))
- (let* ((dbdat (db:get-dbdat dbstruct apath dbfile))
- (db (dbr:dbdat-db dbdat))
- (inmem (dbr:dbdat-inmem dbdat))
- (start-t (current-seconds))
- (last-update (dbr:dbdat-last-write dbdat))
- (last-sync (dbr:dbdat-last-sync dbdat)))
- (debug:print-info 4 *default-log-port* "Syncing for dbfile: " dbfile)
- (mutex-lock! *db-multi-sync-mutex*)
- (let* ((update_info (cons (if force-sync 0 last-update) "last_update"))
- (need-sync (or force-sync (>= last-update last-sync))))
- (if need-sync
- (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
- (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
- (dbr:dbdat-last-sync-set! dbdat start-t)
- (mutex-unlock! *db-multi-sync-mutex*)))
+ #f) ;; disabled
+;; (let* ((dbdat (db:get-dbdat dbstruct apath dbfile))
+;; (dbfullname (conc apath "/" dbfile))
+;; (db (db:open-run-db dbfullname db:initialize-db)) ;; (dbr:dbdat-db dbdat))
+;; (inmem (dbr:dbdat-inmem dbdat))
+;; (start-t (current-seconds))
+;; (last-update (dbr:dbdat-last-write dbdat))
+;; (last-sync (dbr:dbdat-last-sync dbdat)))
+;; (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync)
+;; (mutex-lock! *db-multi-sync-mutex*)
+;; (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;; "last_update"))
+;; (need-sync (or force-sync (>= last-update last-sync))))
+;; (if need-sync
+;; (begin
+;; (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
+;; (dbr:dbdat-last-sync-set! dbdat start-t))
+;; (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
+;; (sqlite3:finalize! db)
+;; (mutex-unlock! *db-multi-sync-mutex*)))
;; TODO: Add final sync to this
;;
-(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
+#;(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
(if (<= try-num 0)
#f
(handle-exceptions
exn
(begin
@@ -451,11 +480,11 @@
(sqlite3:finalize! db)
#t)
#f))))
;; close all opened run-id dbs
-(define (db:close-all dbstruct)
+#;(define (db:close-all dbstruct)
(assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.")
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
@@ -643,38 +672,23 @@
(sqlite3:execute db "vacuum;")))
(sqlite3:finalize! db)
#t))))))
+;; last-update is *always* a pair ( fieldname|#f . last-update-seconds|#f)
(define (db:sync-one-table fromdb todb tabledat last-update numrecs)
+ (assert (pair? last-update) "FATAL: last-update must always be a pair.")
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(has-last-update (member "last_update" fields))
- (use-last-update (cond
- ((and has-last-update
- (member "last_update" fields))
- #t) ;; if given a number, just use it for all fields
- ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
- ((and (pair? last-update)
- (member (car last-update) ;; last-update field name
- (map car fields)))
- #t)
- (last-update
- (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
- #f)
- (else
- #f)))
- (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
- (if (number? last-update)
- last-update
- (cdr last-update))
- #f))
- (last-update-field (if use-last-update
- (if (number? last-update)
+ (last-update-field (or (car last-update)
+ (if has-last-update
"last_update"
- (car last-update))
- #f))
+ #f)))
+ (has-field (member last-update-field fields))
+ (last-update-value (cdr last-update))
+ (use-last-update (and has-field last-update-field last-update-value))
(num-fields (length fields))
(field->num (make-hash-table))
(num->field (apply vector (map car fields))) ;; BBHERE
(full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
" FROM " tablename (if use-last-update ;; apply last-update criteria
@@ -757,10 +771,11 @@
(if (and same
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
+ (debug:print 0 *default-log-port* "applying data "fromrow"to table "tablename", numrecs="numrecs)
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
fromdat-lst))))
fromdats)
(sqlite3:finalize! stmth)
@@ -773,11 +788,11 @@
;; if last-update specified ("field-name" . time-in-seconds)
;; then sync only records where field-name >= time-in-seconds
;; IFF field-name exists
;;
(define (db:sync-tables tbls last-update fromdb todb)
-
+ (assert (pair? last-update) "FATAL: last-update must always be a pair")
;; NOTE: I'm moving all the checking OUT of this routine. Check for read/write access, existance, etc
;; BEFORE calling this sync
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
@@ -798,11 +813,11 @@
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
(set! tot-count (+ tot-count count))
(if (> count 0)
- (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
+ (if should-print (debug:print 0 *default-log-port* " "tblname" "count))))) ;; (format #f " ~10a ~5a" tblname count))))))
(sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
tot-count))
(define (db:patch-schema-rundb frundb)
;;
@@ -1177,24 +1192,24 @@
BEGIN
UPDATE test_data SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )))
-(define (db:create-all-triggers dbstruct)
+(define (db:create-all-triggers dbstruct run-id)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(db:create-triggers db))))
(define (db:create-triggers db)
(for-each (lambda (key)
(sqlite3:execute db (cadr key)))
db:trigger-list))
-(define (db:drop-all-triggers dbstruct)
+(define (db:drop-all-triggers dbstruct run-id)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(db:drop-triggers db))))
(define (db:is-trigger-dropped db tbl-name)
(let* ((trigger-name (if (equal? tbl-name "test_steps")
@@ -1623,11 +1638,11 @@
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
72000))) ;; twenty hours
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
@@ -1706,11 +1721,11 @@
)
(debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
(debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(let* ((stmth1 (db:get-cache-stmth
dbstruct db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
@@ -1828,11 +1843,11 @@
)))))))
;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
- (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
+ (db:general-call dbstruct 'top-test-set-per-pf-counts run-id (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
@@ -1978,18 +1993,18 @@
;; dead-runs))
;;======================================================================
;; 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 dbstruct var)
+(define (db:get-var dbstruct run-id var)
(let* ((res #f))
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
@@ -1998,17 +2013,17 @@
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
res))))
-(define (db:inc-var dbstruct var)
- (db:with-db dbstruct #f #t
+(define (db:inc-var dbstruct run-id var)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
-(define (db:dec-var dbstruct var)
- (db:with-db dbstruct #f #t
+(define (db:dec-var dbstruct run-id var)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
@@ -2020,22 +2035,22 @@
;; (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 *default-log-port* "launch throttle factor=" *global-delta*)
;; (set! *last-global-delta-printed* *global-delta*)))
-(define (db:set-var dbstruct var val)
- (db:with-db dbstruct #f #t
+(define (db:set-var dbstruct run-id var val)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
-(define (db:add-var dbstruct var val)
- (db:with-db dbstruct #f #t
+(define (db:add-var dbstruct run-id var val)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
-(define (db:del-var dbstruct var)
- (db:with-db dbstruct #f #t
+(define (db:del-var dbstruct run-id var)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
@@ -2089,11 +2104,11 @@
(if newres
newres
res))
res)))
-(define (db:no-sync-close-db db stmt-cache)
+#;(define (db:no-sync-close-db db stmt-cache)
(db:safely-close-sqlite3-db db stmt-cache))
;; transaction protected lock aquisition
;; either:
;; fails returns (#f . lock-creation-time)
@@ -2245,10 +2260,45 @@
(db:with-db
dbstruct #f #f
(lambda (db)
(let ((res #f))
(apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
+ allvals)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! res id))
+ db
+ (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
+ qry)
+ qryvals)
+ (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
+ res)))
+ (begin
+ (debug:print-error 0 *default-log-port* "Called without all necessary keys")
+ #f))))
+
+;; register a run with the db
+;;
+(define (db:insert-run dbstruct run-id keyvals runname state status user contour-in)
+ (let* ((keys (map car keyvals))
+ (keystr (keys->keystr keys))
+ (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible.
+ (comma (if (> (length keys) 0) "," ""))
+ (andstr (if (> (length keys) 0) " AND " ""))
+ (valslots (keys->valslots keys)) ;; ?,?,? ...
+ (allvals (append (list runname state status user contour) (map cadr keyvals)))
+ (qryvals (append (list runname) (map cadr keyvals)))
+ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
+ (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
+ (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
+ (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (db)
+ (let ((res #f))
+ (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (id,runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,?,strftime('%s','now'),?" comma valslots ");")
+ run-id
allvals)
(apply sqlite3:for-each-row
(lambda (id)
(set! res id))
db
@@ -2466,11 +2516,11 @@
;;
(define (db:update-run-stats dbstruct run-id stats)
;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
- #f
+ run-id
#f
(lambda (db)
;; remove previous data
@@ -3023,14 +3073,14 @@
;; 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)
- (db:general-call dbstruct 'delete-test-step-records (list test-id))
- (db:general-call dbstruct 'delete-test-data-records (list test-id))
+ (db:general-call dbstruct 'delete-test-step-records run-id (list test-id))
+ (db:general-call dbstruct 'delete-test-data-records run-id (list test-id))
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
;;
(define (db:delete-old-deleted-test-records dbstruct)
@@ -3085,31 +3135,25 @@
test-ids))
;; ;; 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
;;
+;; NOTE: processing triggers was called here - moved upstream
+;;
;; NOTE: run-id is not used
;; ;;
-(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
- (db:with-db
- dbstruct
- ;; run-id
- #f
- #t
- (lambda (db)
- (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 dbstruct run-id test-id newstate newstatus))
+(define (db:test-set-state-status db run-id test-id newstate newstatus newcomment)
+ (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 test-id)))))
;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id) ;; fastmode)
(let* ((qry ;; (if fastmode
@@ -3562,13 +3606,13 @@
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 dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
+ (db:general-call dbstruct 'pass-fail-counts run-id (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 dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
+ (db:general-call dbstruct 'test_data-pf-rollup run-id (list test-id test-id test-id test-id))))))
;; each section is a rule except "final" which is the final result
;;
;; [rule-5]
;; operator in
@@ -3869,40 +3913,44 @@
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (if tl-testdat
(db:test-get-id tl-testdat)
#f)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (db:general-call dbstruct 'set-test-start-time (list test-id)))
- (mutex-lock! *db-transaction-mutex*)
+ (db:general-call dbstruct 'set-test-start-time run-id (list test-id)))
+ ;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
;; NB// Pass the db so it is part fo the transaction
- (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
+ ;; this call sets the item state/status
+ (db:test-set-state-status db run-id test-id state status comment)
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
(let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
(state-stauses (db:roll-up-rules state-status-counts state status))
(newstate (car state-stauses))
(newstatus (cadr state-stauses)))
(debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: "
(apply conc
(map (lambda (x)
(conc
- (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
- state-status-counts))); end debug:print
-
+ (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
+ state-status-counts))); end debug:print
+
(if tl-test-id
(db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
))))))
- (mutex-unlock! *db-transaction-mutex*)
+ ;; (mutex-unlock! *db-transaction-mutex*)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
- tr-res)))))
+ tr-res)))
+ ;; this was moved out of test-set-state-status
+ (mt:process-triggers dbstruct run-id test-id state status)))
+
(define (db:roll-up-rules state-status-counts state status)
(let* ((running (length (filter (lambda (x)
(member (dbr:counts-state x) *common:running-states*))
state-status-counts)))
@@ -3957,11 +4005,11 @@
;; NB// Pass the db so it is part of the transaction
(list newstate newstatus)))
(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
- (mutex-lock! *db-transaction-mutex*)
+ ;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct #f #f
(lambda (db)
(let ((tr-res
(sqlite3:with-transaction
@@ -3971,11 +4019,11 @@
(state-stauses (db:roll-up-rules state-status-counts #f #f ))
(newstate (car state-stauses))
(newstatus (cadr state-stauses)))
(if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
(db:set-run-state-status dbstruct run-id newstate newstatus )))))))
- (mutex-unlock! *db-transaction-mutex*)
+ ;; (mutex-unlock! *db-transaction-mutex*)
tr-res))))
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
(let* ((test-count-recs (db:with-db
@@ -4233,18 +4281,18 @@
(else
(hash-table-set! *logged-in-clients* client-signature (current-seconds))
'(#t "successful login"))))
-(define (db:general-call dbstruct stmtname params)
+(define (db:general-call dbstruct stmtname run-id params)
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(apply sqlite3:execute db query params)
#t))))
;; get a summary of state and status counts to calculate a rollup
@@ -5156,11 +5204,11 @@
actual-state " "
actual-status " "
event-time
))
(prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
- (setenv "NBFAKE_LOG" (conc (cond
+ (set-environment-variable! "NBFAKE_LOG" (conc (cond
((and (directory-exists? test-rundir)
(file-writable? test-rundir))
test-rundir)
((and (directory-exists? *toppath*)
(file-writable? *toppath*))
@@ -5171,12 +5219,12 @@
;; (call-with-environment-variables
;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
;; (lambda ()
(process-run fullcmd)
(if prev-nbfake-log
- (setenv "NBFAKE_LOG" prev-nbfake-log)
- (unsetenv "NBFAKE_LOG"))
+ (set-environment-variable! "NBFAKE_LOG" prev-nbfake-log)
+ (unset-environment-variable! "NBFAKE_LOG"))
)) ;; ))
(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
(if test-id
(let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id)))
@@ -5248,16 +5296,16 @@
(if (and (common:file-exists? tconfig-file)
(file-readable? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE"))
(bigmodenv (module-environment 'bigmod)))
- (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
+ (if link-tree-path (set-environment-variable! "MT_LINKTREE" link-tree-path))
(let ((newtcfg (configf:read-config tconfig-file #f #f env-to-use: bigmodenv))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
- (setenv "MT_LINKTREE" old-link-tree)
- (unsetenv "MT_LINKTREE"))
+ (set-environment-variable! "MT_LINKTREE" old-link-tree)
+ (unset-environment-variable! "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
#f)
@@ -5537,10 +5585,30 @@
(begin
(sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
host port servkey pid ipaddr apath dbname)
(db:get-server-info dbstruct apath dbname)))))))))
+;; run this one in a transaction where first check if host:port is taken
+(define (db:deregister-server dbstruct host port servkey pid ipaddr apath dbname)
+ (db:with-db
+ dbstruct
+ #f #f
+ (lambda (db)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let* ((sinfo (db:get-server-info dbstruct apath dbname)))
+ (if (not sinfo)
+ (begin
+ (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port)
+ #f) ;; server already deregistered
+ (begin
+ (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
+ ;; host port servkey pid ipaddr
+ apath dbname)
+ #;(db:get-server-info dbstruct apath dbname)))))))))
+
(define (db:get-server-info dbstruct apath dbname)
(db:with-db
dbstruct
#f #f
(lambda (db)
@@ -5549,7 +5617,20 @@
(list host port servkey pid ipaddr apath dbpath))
#f
db
"SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;"
apath dbname))))
+
+(define (db:get-count-servers dbstruct apath)
+ (db:with-db
+ dbstruct
+ #f #f
+ (lambda (db)
+ (sqlite3:fold-row
+ (lambda (res count)
+ (max res count))
+ 0
+ db
+ "SELECT count(*) FROM servers WHERE apath=?;"
+ apath))))
)
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -19,25 +19,28 @@
;;======================================================================
(use format)
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
-(import canvas-draw-iup)
+(import canvas-draw)
+;; (import canvas-draw-iup)
(use regex typed-records matchable)
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
+(declare (uses mtver))
;; (declare (uses synchash))
-(include "megatest-version.scm")
+;; (include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
+
+(import mtver)
;; yes, this is non-ideal
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)
Index: docs/manual/server.dot
==================================================================
--- docs/manual/server.dot
+++ docs/manual/server.dot
@@ -17,61 +17,65 @@
digraph G {
subgraph cluster_1 {
node [style=filled,shape=box];
- check_available_queue -> remove_entries_over_10s_old;
- remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
- remove_entries_over_10s_old -> exit [label="num_avail > 2"];
-
- set_available -> delay_2s;
- delay_2s -> check_place_in_queue;
-
- check_place_in_queue -> "http:transport-launch" [label="at head"];
- check_place_in_queue -> exit [label="not at head"];
-
- "client:login" -> "server:shutdown" [label="login failed"];
- "server:shutdown" -> exit;
-
- subgraph cluster_2 {
- "http:transport-launch" -> "http:transport-run";
- "http:transport-launch" -> "http:transport-keep-running";
-
- "http:transport-keep-running" -> "tests running?";
- "tests running?" -> "client:login" [label=yes];
- "tests running?" -> "server:shutdown" [label=no];
- "client:login" -> delay_5s [label="login ok"];
- delay_5s -> "http:transport-keep-running";
- }
-
- // start_server -> "server_running?";
- // "server_running?" -> set_available [label="no"];
- // "server_running?" -> delay_2s [label="yes"];
- // delay_2s -> "still_running?";
- // "still_running?" -> ping_server [label=yes];
- // "still_running?" -> set_available [label=no];
- // ping_server -> exit [label=alive];
- // ping_server -> remove_server_record [label=dead];
- // remove_server_record -> set_available;
- // set_available -> avail_delay [label="delay 3s"];
- // avail_delay -> "first_in_queue?";
- //
- // "first_in_queue?" -> set_running [label=yes];
- // set_running -> get_next_port -> handle_requests;
- // "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
- // "dead_entry_in_queue?" -> "server_running?" [label=no];
- // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
- // remove_dead_entries -> "server_running?";
- //
- // handle_requests -> start_shutdown [label="no traffic\nno running tests"];
- // handle_requests -> shutdown_request;
- // start_shutdown -> shutdown_delay;
- // shutdown_request -> shutdown_delay;
- // shutdown_delay -> exit;
-
- label = "server:launch";
- color=brown;
+ rmt:send-receive -> "init-*remote* if needed" -> rmt:general-open-connection ->
+ rmt:send-receive-real;
+
+
+// check_available_queue -> remove_entries_over_10s_old;
+// remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
+// remove_entries_over_10s_old -> exit [label="num_avail > 2"];
+//
+// set_available -> delay_2s;
+// delay_2s -> check_place_in_queue;
+//
+// check_place_in_queue -> "http:transport-launch" [label="at head"];
+// check_place_in_queue -> exit [label="not at head"];
+//
+// "client:login" -> "server:shutdown" [label="login failed"];
+// "server:shutdown" -> exit;
+//
+// subgraph cluster_2 {
+// "http:transport-launch" -> "http:transport-run";
+// "http:transport-launch" -> "http:transport-keep-running";
+//
+// "http:transport-keep-running" -> "tests running?";
+// "tests running?" -> "client:login" [label=yes];
+// "tests running?" -> "server:shutdown" [label=no];
+// "client:login" -> delay_5s [label="login ok"];
+// delay_5s -> "http:transport-keep-running";
+// }
+//
+// // start_server -> "server_running?";
+// // "server_running?" -> set_available [label="no"];
+// // "server_running?" -> delay_2s [label="yes"];
+// // delay_2s -> "still_running?";
+// // "still_running?" -> ping_server [label=yes];
+// // "still_running?" -> set_available [label=no];
+// // ping_server -> exit [label=alive];
+// // ping_server -> remove_server_record [label=dead];
+// // remove_server_record -> set_available;
+// // set_available -> avail_delay [label="delay 3s"];
+// // avail_delay -> "first_in_queue?";
+// //
+// // "first_in_queue?" -> set_running [label=yes];
+// // set_running -> get_next_port -> handle_requests;
+// // "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
+// // "dead_entry_in_queue?" -> "server_running?" [label=no];
+// // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
+// // remove_dead_entries -> "server_running?";
+// //
+// // handle_requests -> start_shutdown [label="no traffic\nno running tests"];
+// // handle_requests -> shutdown_request;
+// // start_shutdown -> shutdown_delay;
+// // shutdown_request -> shutdown_delay;
+// // shutdown_delay -> exit;
+//
+// label = "server:launch";
+// color=brown;
}
// client_start_server -> start_server;
// handle_requests -> read_write;
// read_write -> handle_requests;
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -141,11 +141,11 @@
;; (print "COMMON: " (string-intersperse common-parts "\n "))
(string-intersperse final separator)))
(define (env:process-path-envvar varname separator patha pathb)
(let ((newpath (env:merge-path-envvar separator patha pathb)))
- (setenv varname newpath)))
+ (set-environment-variable! varname newpath)))
(define (env:have-context db context)
(> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
0))
Index: ezstepsmod.scm
==================================================================
--- ezstepsmod.scm
+++ ezstepsmod.scm
@@ -132,11 +132,11 @@
(logpro-file (conc stepname ".logpro"))
(html-file (conc stepname ".html"))
(dat-file (conc stepname ".dat"))
(tconfig-logpro (configf:lookup testconfig "logpro" stepname))
(logpro-used (common:file-exists? logpro-file)))
- (setenv "MT_STEP_NAME" stepname)
+ (set-environment-variable! "MT_STEP_NAME" stepname)
(hash-table-set! all-steps-dat stepname `((params . ,paramparts)))
(debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
(if (and tconfig-logpro
@@ -203,11 +203,11 @@
(processloop (+ i 1))))
)))))
(debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
;; now run logpro if needed
(if logpro-used
- (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
+ (let* ((logpro-exe (or (get-environment-variable "LOGPRO_EXE") "logpro"))
(pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
Index: itemsmod.scm
==================================================================
--- itemsmod.scm
+++ itemsmod.scm
@@ -20,10 +20,11 @@
(declare (unit itemsmod))
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses configfmod))
+(declare (uses commonmod))
(module itemsmod
*
(import scheme
@@ -164,14 +165,14 @@
(set! res (append res (list item)))
(loop (+ indx 1)
'()
#f)))
res)))
- ;; Nope, not now, return null as of 6/6/2011
-
-(define (items:check-valid-items class item)
- (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
+;; Nope, not now, return null as of 6/6/2011
+
+(define (items:check-valid-items valid-values class item)
+ (let ((valid-values (let ((s valid-values)) ;; (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
Index: launchmod.scm
==================================================================
--- launchmod.scm
+++ launchmod.scm
@@ -125,11 +125,11 @@
(debug:print 0 *default-log-port* "keep-going=" keep-going)
(and keep-going (equal? (car keep-going) "yes")))))
;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
- (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
+ (let ((enccmd (if encoded-cmd encoded-cmd (get-environment-variable "MT_CMDINFO"))))
(if enccmd
(common:read-encoded-string enccmd)
'())))
(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
@@ -218,11 +218,11 @@
;; check exit-info (vector-ref exit-info 1)
(if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
(let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat))
(stepname (car ezstep))
(stepparms (hash-table-ref all-steps-dat stepname)))
- (setenv "MT_STEP_NAME" stepname)
+ (set-environment-variable! "MT_STEP_NAME" stepname)
(pp (hash-table->alist all-steps-dat))
;; if logpro-used read in the stepname.dat file
(if (and logpro-used (common:file-exists? (conc stepname ".dat")))
(launch:load-logpro-dat run-id test-id stepname))
(if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
@@ -286,11 +286,11 @@
(set! kill-job? #f)))
(debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
(launch:handle-zombie-tests run-id)
(when do-sync
- ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
+ ;;(with-output-to-file (conc (get-environment-variable "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds)))
(tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
)
@@ -355,11 +355,11 @@
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
- (setenv "MT_CMDINFO" encoded-cmd)
+ (set-environment-variable! "MT_CMDINFO" encoded-cmd)
;;(bb-check-path msg: "launch:execute incoming")
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
(let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area
(top-path (assoc/default 'toppath cmdinfo))
@@ -434,31 +434,31 @@
(launch:test-copy testpath work-area))))
;; one more time, change to the work-area directory
(change-directory work-area)))
) ;; let*
- (if contour (setenv "MT_CONTOUR" contour))
+ (if contour (set-environment-variable! "MT_CONTOUR" contour))
;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
;;
- (setenv "MT_TESTSUITENAME" areaname)
- (setenv "MT_RUN_AREA_HOME" top-path)
+ (set-environment-variable! "MT_TESTSUITENAME" areaname)
+ (set-environment-variable! "MT_RUN_AREA_HOME" top-path)
(set! *toppath* top-path)
(change-directory *toppath*) ;; temporarily switch to the run area home
- (setenv "MT_TEST_RUN_DIR" work-area)
+ (set-environment-variable! "MT_TEST_RUN_DIR" work-area)
(launch:setup) ;; should be properly in the run area home now
- (if contour (setenv "MT_CONTOUR" contour))
+ (if contour (set-environment-variable! "MT_CONTOUR" contour))
;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
;;
- (setenv "MT_TESTSUITENAME" areaname)
- (setenv "MT_RUN_AREA_HOME" top-path)
+ (set-environment-variable! "MT_TESTSUITENAME" areaname)
+ (set-environment-variable! "MT_RUN_AREA_HOME" top-path)
(set! *toppath* top-path)
(change-directory *toppath*) ;; temporarily switch to the run area home
- (setenv "MT_TEST_RUN_DIR" work-area)
+ (set-environment-variable! "MT_TEST_RUN_DIR" work-area)
(launch:setup) ;; should be properly in the run area home now
(set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
(let ((sighand (lambda (signum)
@@ -592,19 +592,19 @@
(let ((varval (string-split varpair "=")))
(if (eq? (length varval) 2)
(let ((var (car varval))
(val (cadr varval)))
(debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment")
- (setenv var val)))))
+ (set-environment-variable! var val)))))
varpairs)))
;;(bb-check-path msg: "launch:execute post block 2")
(for-each
(lambda (varval)
(let ((var (car varval))
(val (cadr varval)))
(if val
- (setenv var val)
+ (set-environment-variable! var val)
(begin
(debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting")
(exit)))))
(list
(list "MT_TEST_RUN_DIR" work-area)
@@ -616,11 +616,11 @@
(list "MT_TARGET" target)
(list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(list "MT_TESTSUITENAME" (common:get-area-name))))
;;(bb-check-path msg: "launch:execute post block 3")
- (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
+ (if mt-bindir-path (set-environment-variable! "PATH" (conc (get-environment-variable "PATH") ":" mt-bindir-path)))
;;(bb-check-path msg: "launch:execute post block 4")
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
@@ -635,11 +635,11 @@
(let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars")))
(if blacklist
(let ((vars (string-split blacklist)))
(save-environment-as-files "megatest" ignorevars: vars)
(for-each (lambda (var)
- (unsetenv var))
+ (unset-environment-variable! var))
vars))
(save-environment-as-files "megatest")))
;;(bb-check-path msg: "launch:execute post block 44")
;; open-run-close not needed for test-set-meta-info
;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
@@ -768,11 +768,11 @@
(args:get-arg "-execute")))
(let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE"))
(target (common:args-get-target exit-if-bad: #t))
(runname (or (args:get-arg "-runname")
(args:get-arg ":runname")
- (getenv "MT_RUNNAME")))
+ (get-environment-variable "MT_RUNNAME")))
(fulldir (conc linktree "/"
target "/"
runname)))
(if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree
(begin
@@ -921,16 +921,16 @@
(set! toppath *toppath*)
(if (not *toppath*)
(begin
(debug:print-error 0 *default-log-port* "you are not in a megatest area!")
(exit 1)))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
(let* ((keys (common:list-or-null (rmt:get-keys)
message: "Failed to retrieve keys in launch.scm. Please report this to the developers."))
(key-vals (keys:target->keyval keys target))
- (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (linktree (common:get-linktree)) ;; (or (get-environment-variable "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
; (if *configdat*
; (configf:lookup *configdat* "setup" "linktree")
; (conc *toppath* "/lt"))))
(second-pass (configf:find-and-read-config
mtconfig
@@ -938,11 +938,11 @@
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"
env-to-use: (module-environment 'bigmod)))
(runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
(for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
+ (set-environment-variable! (car kt) (cadr kt)))
key-vals)
(configf:read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
sections: sections)))
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
@@ -1018,12 +1018,12 @@
(debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
)))
(if (and *toppath*
(directory-exists? *toppath*))
(begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (setenv "MT_TESTSUITENAME" (common:get-area-name)))
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_TESTSUITENAME" (common:get-area-name)))
(begin
(debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
(set! *toppath* #f) ;; force it to be false so we return #f
#f))
@@ -1299,21 +1299,21 @@
(define (launch:handle-zombie-tests run-id)
(let* ((key (conc "zombiescan-runid-"run-id))
(now (current-seconds))
(threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120))))
- (val (rmt:get-var key))
+ (val (rmt:get-var run-id key))
(do-scan?
(cond
((not val)
#t)
((< val threshold)
#t)
(else #f))))
(when do-scan?
(debug:print 1 *default-log-port* "INFO: search and mark zombie tests")
- (rmt:set-var key (current-seconds))
+ (rmt:set-var run-id key (current-seconds))
(runs:find-and-mark-incomplete-and-check-end-of-run run-id #f))))
@@ -1888,29 +1888,29 @@
;; 0 RUNNING ==> this is actually the first condition, should not get here
(define (runs:end-of-run-check run-id )
(let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
(running-cnt (rmt:get-count-tests-running-for-run-id run-id))
- (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
+ (all-test-launched (rmt:get-var run-id (conc "lunch-complete-" run-id)))
(current-state (rmt:get-run-state run-id))
(current-status (rmt:get-run-status run-id)))
;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing
(debug:print 0 *default-log-port* "Running test cnt :" running-cnt)
(rmt:set-state-status-and-roll-up-run run-id current-state current-status)
(runs:update-junit-test-reporter-xml run-id)
(cond
((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
- (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
+ (if (and (equal? (rmt:get-var run-id (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
(begin
- (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id)))
+ (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var run-id (conc "end-of-run-" run-id)))
(debug:print 0 *default-log-port* "End of Run Detected.")
(rmt:set-var (conc "end-of-run-" run-id) "yes")
;(thread-sleep! 10)
(runs:run-post-hook run-id)
- (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id)))
+ (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var run-id (conc "end-of-run-" run-id)))
(common:simple-unlock (conc "endOfRun" run-id)))
- (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id)))))
+ (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var run-id (conc "end-of-run-" run-id)))))
((> running-cnt 3)
(debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
((> running-cnt 0)
(debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
(let ((kill-cnt (launch:kill-tests-if-dead run-id)))
@@ -1968,11 +1968,11 @@
#f ;; get full data (not 'shortlist)
0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
'dashboard)
'()))
(log-dir (conc *toppath* "/logs"))
- (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
+ (log-file (conc "post-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log"))
(full-log-fname (conc log-dir "/" log-file)))
(if run-post-hook
;; (if (null? existing-tests)
;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
(let* ((use-log-dir (if (not (directory-exists? log-dir))
@@ -1998,11 +1998,11 @@
(define (runs:rerun-hook test-id new-test-path testdat rerunlst)
(let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook"))
(log-dir (conc *toppath* "/reruns/logs"))
- (target (getenv "MT_TARGET"))
+ (target (get-environment-variable "MT_TARGET"))
(runname (common:args-get-runname))
(rundir (db:test-get-rundir testdat))
(tarfiledir (conc *toppath* "/reruns"))
(status (db:test-get-status testdat))
(comment (conc "\"" (db:test-get-comment testdat) "\"" ))
@@ -2053,14 +2053,14 @@
(let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
(junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir"))
(xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
(if junit-test-report-dir
junit-test-report-dir
- (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
+ (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME")))
#f))
(xml-ts-name (if xml-dir
- (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
+ (conc (get-environment-variable "MT_TESTSUITENAME")"."(string-translate (get-environment-variable "MT_TARGET") "/" ".") "." (get-environment-variable "MT_RUNNAME"))
#f))
(keyname (if xml-ts-name (common:get-signature xml-ts-name) #f))
(xml-path (if xml-dir
(conc xml-dir "/" keyname ".xml")
#f))
@@ -2141,11 +2141,11 @@
(testsuite)))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
- (setenv (car item) (cadr item)))
+ (set-environment-variable! (car item) (cadr item)))
itemdat))
;; set up needed environment variables given a run-id and optionally a target, itempath etc.
;;
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
@@ -2155,16 +2155,16 @@
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (common:get-fields *configdat*) #;(rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
(link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
- (if testname (setenv "MT_TEST_NAME" testname))
- (if itempath (setenv "MT_ITEMPATH" itempath))
+ (if testname (set-environment-variable! "MT_TEST_NAME" testname))
+ (if itempath (set-environment-variable! "MT_ITEMPATH" itempath))
;; get the info from the db and put it in the cache
(if link-tree
- (setenv "MT_LINKTREE" link-tree)
+ (set-environment-variable! "MT_LINKTREE" link-tree)
(debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
@@ -2180,11 +2180,11 @@
(debug:print 2 *default-log-port* "setenv " key " " val)
(safe-setenv key val)))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 1")
;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals))
- (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
+ (if (not (get-environment-variable "MT_TARGET"))(set-environment-variable! "MT_TARGET" target))
;; we had a case where there was an exception generated by the hash-table-ref
;; due to *configdat* being #f Adding a handle and exit
(let fatal-loop ((count 0))
(handle-exceptions
exn
@@ -2217,22 +2217,22 @@
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
(if runname
- (setenv "MT_RUNNAME" runname)
+ (set-environment-variable! "MT_RUNNAME" runname)
(debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
;; if a testname and itempath are available set the remaining appropriate variables
- (if testname (setenv "MT_TEST_NAME" testname))
- (if itempath (setenv "MT_ITEMPATH" itempath))
+ (if testname (set-environment-variable! "MT_TEST_NAME" testname))
+ (if itempath (set-environment-variable! "MT_ITEMPATH" itempath))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 3")
(if (and testname link-tree)
- (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
- (getenv "MT_TEST_NAME")
+ (set-environment-variable! "MT_TEST_RUN_DIR" (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
+ (get-environment-variable "MT_TEST_NAME")
(if (and itempath
(not (equal? itempath "")))
(conc "/" itempath)
""))))))
@@ -2244,12 +2244,12 @@
;; (if (eq? *configstatus* 'fulldata)
;; *runconfigdat*
;; (begin
;; (launch:setup)
;; *runconfigdat*)))
- (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
- (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
+ (let* ((rundir (if (and (get-environment-variable "MT_LINKTREE")(get-environment-variable "MT_TARGET")(get-environment-variable "MT_RUNNAME"))
+ (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME"))
#f))
(cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
(if (and cfgf
(file-exists? cfgf)
(file-writable? cfgf)
@@ -2258,14 +2258,14 @@
(let* ((keys (common:get-fields *configdat*)) ;; (rmt:get-keys))
(target (common:args-get-target))
(key-vals (if target (keys:target->keyval keys target) #f))
(sections (if target (list "default" target) #f))
(data (begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
(if key-vals
(for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
+ (set-environment-variable! (car kt) (cadr kt)))
key-vals))
;; (configf:read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
(runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
(if (and rundir ;; have all needed variabless
(directory-exists? rundir)
@@ -2289,13 +2289,16 @@
(dbfile (args:get-arg "-db"))
(apath *toppath*))
(let loop ()
(thread-sleep! 5) ;; add control / setting for this
(if am-server
- (if (not *dbstruct-db*)
+ (if (not *dbstruct-db*) ;; skip syncing until db is setup
(loop)
- (db:sync-inmem->disk *dbstruct-db* *toppath* dbfile))))))
+ (begin
+ ;; (debug:print-info 0 *default-log-port* "syncing "apath" "dbfile" at "(current-seconds))
+ ;; (db:sync-inmem->disk *dbstruct-db* apath dbfile)
+ (loop)))))))
;;
;; (let ((dbstruct
;; (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
;; (cond
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -128,11 +128,10 @@
;; local modules
autoload
adjutant
csv-xml
- ducttape-lib
hostinfo
mtver
mutils
cookie
csv-xml
@@ -169,13 +168,13 @@
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
-(include "common.scm")
+;; (include "common.scm")
(include "db.scm")
-(include "server.scm")
+;; (include "server.scm")
(include "tests.scm")
(include "genexample.scm")
(include "tdb.scm")
(include "env.scm")
(include "diff-report.scm")
@@ -182,20 +181,20 @@
(include "ods.scm")
(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
- ;;======================================================================
- ;; Test commands (i.e. for use inside tests)
- ;;======================================================================
-
- (define (megatest:step step state status logfile msg)
- (if (not (getenv "MT_CMDINFO"))
- (begin
+;;======================================================================
+;; Test commands (i.e. for use inside tests)
+;;======================================================================
+
+(define (megatest:step step state status logfile msg)
+ (if (not (get-environment-variable "MT_CMDINFO"))
+ (begin
(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
(exit 5))
- (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (let* ((cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
@@ -215,18 +214,18 @@
(rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
(begin
(debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
(exit 6))))))
- ;;======================================================================
- ;; full run
- ;;======================================================================
-
- (define (handle-run-requests target runname keys keyvals need-clean)
- (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
- ;; For rerun-clean do we or do we not support the testpatt?
- (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
+;;======================================================================
+;; full run
+;;======================================================================
+
+(define (handle-run-requests target runname keys keyvals need-clean)
+ (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
+ ;; For rerun-clean do we or do we not support the testpatt?
+ (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
"KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
(statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
"FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
@@ -244,13 +243,13 @@
;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
(common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: statuses
new-state-status: "NOT_STARTED,n/a")))
- ;; RERUN ALL
- (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
- (let* ((rconfig (full-runconfigs-read)))
+ ;; RERUN ALL
+ (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
+ (let* ((rconfig (full-runconfigs-read)))
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
(common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
@@ -263,80 +262,80 @@
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
(common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;; state: states
status: #f
new-state-status: "NOT_STARTED,n/a")))
- (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
+ (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
(rerun-cnt (if config-reruns
config-reruns
1)))
-
- (runs:run-tests target
+
+ (runs:run-tests target
runname
#f ;; (common:args-get-testpatt #f)
;; (or (args:get-arg "-testpatt")
;; "%")
(bdat-user *bdat*)
args:arg-hash
run-count: rerun-cnt)))
- ;; csv processing record
- (define (make-refdb:csv)
- (vector
- (make-sparse-array)
- (make-hash-table)
- (make-hash-table)
- 0
- 0))
- (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
- (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
- (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
- (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
- (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
- (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
- (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
- (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
- (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
- (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
-
- (define (get-dat results sheetname)
- (or (hash-table-ref/default results sheetname #f)
- (let ((tmp-vec (make-refdb:csv)))
+;; csv processing record
+(define (make-refdb:csv)
+ (vector
+ (make-sparse-array)
+ (make-hash-table)
+ (make-hash-table)
+ 0
+ 0))
+(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
+(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
+(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
+(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
+(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
+(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
+(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
+(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
+(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
+(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
+
+(define (get-dat results sheetname)
+ (or (hash-table-ref/default results sheetname #f)
+ (let ((tmp-vec (make-refdb:csv)))
(hash-table-set! results sheetname tmp-vec)
tmp-vec)))
-
- ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
- (define (open-logfile logpath-in)
- (condition-case
- (let* ((log-dir (or (pathname-directory logpath-in) "."))
+
+;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
+(define (open-logfile logpath-in)
+ (condition-case
+ (let* ((log-dir (or (pathname-directory logpath-in) "."))
(fname (pathname-strip-directory logpath-in))
(logpath (if (> (string-length fname) 250)
(let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
(debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
newlogf)
logpath-in)))
- (if (not (directory-exists? log-dir))
- (system (conc "mkdir -p " log-dir)))
- (open-output-file logpath))
- (exn ()
- (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
- (define *didsomething* #t)
- (exit 1))))
+ (if (not (directory-exists? log-dir))
+ (system (conc "mkdir -p " log-dir)))
+ (open-output-file logpath))
+ (exn ()
+ (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
+ (define *didsomething* #t)
+ (exit 1))))
(define (debug:setup)
(let ((debugstr (or (args:get-arg "-debug")
(args:get-arg "-debug-noprop")
- (getenv "MT_DEBUG_MODE"))))
+ (get-environment-variable "MT_DEBUG_MODE"))))
(set! *verbosity* (debug:calc-verbosity debugstr 'q))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
(if (and (not (args:get-arg "-debug-noprop"))
(or (args:get-arg "-debug")
- (not (getenv "MT_DEBUG_MODE"))))
- (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
+ (not (get-environment-variable "MT_DEBUG_MODE"))))
+ (set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
@@ -349,11 +348,11 @@
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; -daemonize : fork into background and disconnect from stdin/out
-
+
(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
@@ -773,24 +772,24 @@
;; before doing anything else change to the start-dir if provided
;;
(if (args:get-arg "-start-dir")
(if (common:file-exists? (args:get-arg "-start-dir"))
(let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
- (setenv "PWD" fullpath)
+ (set-environment-variable! "PWD" fullpath)
(change-directory fullpath))
(begin
(debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(exit 1))))
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
- (if targ (setenv "MT_TARGET" targ)))
+ (if targ (set-environment-variable! "MT_TARGET" targ)))
;; The watchdog is to keep an eye on things like db sync etc.
;;
-(init-watchdog)
+;; (init-watchdog)
;; (define (debug:debug-mode n)
;; (cond
;; ((and (number? *verbosity*) ;; number number
;; (number? n))
@@ -912,22 +911,23 @@
(hash-table-set! args:arg-hash "-testpatt" newval)
(hash-table-delete! args:arg-hash "-itempatt")))
(if (args:get-arg "-runtests")
(debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
-
- (on-exit std-exit-procedure)
+
+ (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable")
+ ;; (on-exit std-exit-procedure)
;;======================================================================
;; Misc general calls
;;======================================================================
;; TODO: Restore this functionality
#; (if (and (args:get-arg "-cache-db")
(args:get-arg "-source-db"))
- (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
+ (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_")))))
(target-db (conc temp-dir "/cached.db"))
(source-db (args:get-arg "-source-db")))
(db:cache-for-read-only source-db target-db)
(set! *didsomething* #t)))
@@ -1263,12 +1263,12 @@
(set! *didsomething* #t)
(pop-directory)
(bdat-time-to-exit-set! *bdat* #t)))
(if (args:get-arg "-show-cmdinfo")
- (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
- (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
+ (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
+ (let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")))))
(if (equal? (args:get-arg "-dumpmode") "json")
(json-write data)
(pp data))
(set! *didsomething* #t))
(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
@@ -2059,13 +2059,13 @@
;; Get paths to tests
;;======================================================================
;; Get test paths matching target, runname, and testpatt
(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
;; if we are in a test use the MT_CMDINFO data
- (if (getenv "MT_CMDINFO")
+ (if (get-environment-variable "MT_CMDINFO")
(let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
@@ -2226,16 +2226,16 @@
(args:get-arg "-test-status")
(args:get-arg "-set-values")
(args:get-arg "-load-test-data")
(args:get-arg "-runstep")
(args:get-arg "-summarize-items"))
- (if (not (getenv "MT_CMDINFO"))
+ (if (not (get-environment-variable "MT_CMDINFO"))
(begin
(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
(exit 5))
(let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
@@ -2452,11 +2452,11 @@
(args:get-arg "-diff-html")
(args:get-arg "-diff-email"))
(set! *didsomething* #t)
(exit 0)))
- (if (or (getenv "MT_RUNSCRIPT")
+ (if (or (get-environment-variable "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup)))
;; (dbstruct (if (and toppath
@@ -2463,11 +2463,11 @@
;; #;(common:on-homehost?))
;; (db:setup #f) ;; sets up main.db
;; #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
- ((getenv "MT_RUNSCRIPT")
+ ((get-environment-variable "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
;; #!/bin/bash
;;
;; export MT_RUNSCRIPT=yes
ADDED nng-trial/Makefile
Index: nng-trial/Makefile
==================================================================
--- /dev/null
+++ nng-trial/Makefile
@@ -0,0 +1,5 @@
+nng-test : nng-test.scm
+ csc nng-test.scm
+
+test : nng-test
+ ./nng-test do-test
ADDED nng-trial/nng-test.scm
Index: nng-trial/nng-test.scm
==================================================================
--- /dev/null
+++ nng-trial/nng-test.scm
@@ -0,0 +1,153 @@
+(import (chicken io)
+ (chicken file)
+ (chicken file posix)
+ (chicken string)
+ (chicken process-context)
+ (chicken process-context posix)
+ miscmacros
+ nng
+ srfi-18
+ srfi-69
+ test
+ matchable
+ typed-records
+ system-information
+ directory-utils
+ )
+
+(define help "Usage: nng-test COMMAND
+ where COMMAND is one of:
+ dotest : run the basic req/rep test
+")
+
+(define address-tcp-1 "tcp://localhost:5555")
+(define address-tcp-2 "tcp://localhost:6666")
+
+(define address-inproc-1 "inproc://local1")
+(define address-inproc-2 "inproc://local2")
+
+;;;
+;;; Req-Rep
+;;;
+(define (make-listening-reply-socket address)
+ (let ((socket (make-rep-socket)))
+ (socket-set! socket 'nng/recvtimeo 2000)
+ (nng-listen socket address)
+ socket))
+
+(define (make-dialed-request-socket address)
+ (let ((socket (make-req-socket)))
+ (socket-set! socket 'nng/recvtimeo 2000)
+ (nng-dial socket address)
+ socket))
+
+(define (req-rep-test address)
+ (let ((rep (make-listening-reply-socket address))
+ (req (make-dialed-request-socket address)))
+ (nng-send req "message 1")
+ (nng-recv rep)
+ (nng-send rep "message")
+ (begin0
+ (nng-recv req)
+ (nng-close! rep))))
+
+(define (do-test)
+ (test-group "nng"
+ (test "tcp req-rep"
+ "message"
+ (req-rep-test address-tcp-1))
+ (test "inproc req-rep"
+ "message"
+ (req-rep-test address-inproc-1)))
+ (test-exit))
+
+;; talking to self here...
+;;
+(define (send-n-messages n srvdat)
+ (let* ((name (srv-name srvdat)))
+ (let loop ((i 0))
+ (if (< i n)
+ (begin
+ (nng-send (srv-req srvdat) (conc name "-" i))
+ (print "received: "(nng-recv (srv-rep srvdat)))
+ (loop (+ i 1)))))))
+
+;; this should be run in a thread
+(define (run-listener-responder socket myaddr)
+ (let loop ((status 'running))
+ (let* ((msg (nng-recv socket))
+ (response (process-message msg)))
+ (if (not (eq? response 'done))
+ (begin
+ (nng-send socket response)
+ (loop status))))))
+
+(define *channels* (make-hash-table))
+
+(define (call channels msg addr)
+ (let* ((csocket (hash-table-ref/default channels addr #f))
+ (socket (or csocket (make-dialed-request-socket addr))))
+ (nng-send socket msg)
+ (print "Sent: "msg", received: "(nng-recv socket))
+ (if (not (hash-table-exists? channels addr))
+ (hash-table-set! channels addr socket))))
+
+;; start => hello 0
+;; hello 0 => hello 1
+;; hello 1 => hello 2
+;; ...
+;; hello 11 => 'done
+;;
+(define (process-message mesg)
+ (let ((parts (string-split mesg)))
+ (match
+ parts
+ ((msg c)
+ (let ((count (string->number c)))
+ (if (> count 10)
+ 'done
+ (conc msg " " (if count count 0)))))
+ ((msg)
+ (conc msg " 0"))
+ (else
+ "hello 0"))))
+
+(define (close-srv srvdat)
+ (nng-close! (srv-rep srvdat)))
+
+(match
+ (command-line-arguments)
+ (("do-test")(do-test))
+ ((run myaddr)
+ ;; start listener
+ ;; put myaddr into file by host-pid in .runners
+ ;; for 1 minute
+ ;; get all in .runners
+ ;; call each with a message
+ ;;
+ (let* ((socket (make-listening-reply-socket myaddr))
+ (rfile (conc ".runners/"(get-host-name)"-"(current-process-id)))
+ (th1 (make-thread (lambda ()
+ (run-listener-responder socket myaddr)
+ (delete-file* rfile)
+ (exit))
+ "responder")))
+ (if (not (and (file-exists? ".runners")
+ (directory? ".runners")))
+ (create-directory ".runners" #t))
+ (with-output-to-file rfile
+ (lambda ()
+ (print myaddr)))
+ (thread-start! th1)
+ (let loop ((entries '()))
+ (if (null? entries)
+ (loop (glob ".runners/*"))
+ (let* ((entry (car entries))
+ (destaddr (with-input-from-file entry read-line)))
+ (call *channels* (conc "hello-from-"destaddr) destaddr)
+ (thread-sleep! 0.25)
+ (loop (cdr entries)))))))
+ ((cmd)(print "ERROR: command "cmd", not recognised.\n\n"help))
+ (else
+ (print help)))
+
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -62,10 +62,11 @@
;; http-client
;; intarweb
matchable
md5
message-digest
+ nng ;; nanomsg
(prefix base64 base64:)
(prefix sqlite3 sqlite3:)
regex
s11n
;; spiffy
@@ -75,11 +76,11 @@
srfi-13
srfi-18
srfi-69
stack
system-information
- tcp6
+ ;; tcp6
typed-records
uri-common
z3
apimod
@@ -119,10 +120,11 @@
;;
(defstruct servdat
(host #f)
(port #f)
(uuid #f)
+ (rep #f)
(dbfile #f)
(api-url #f)
(api-uri #f)
(api-req #f)
(status 'starting)
@@ -243,15 +245,16 @@
(start-main-srv))))
;; NB// remote is a rmt:remote struct
;;
(define (rmt:general-open-connection remote apath dbname #!key (num-tries 5))
- (let ((mdbname (db:run-id->dbname #f)))
+ (let* ((mdbname (db:run-id->dbname #f))
+ (mconn (rmt:get-conn remote apath mdbname)))
(cond
- ((not (rmt:get-conn remote apath mdbname)) ;; no channel open to main?
+ ((or (not mconn) ;; no channel open to main?
+ (< (rmt:conn-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease
(rmt:open-main-connection remote apath)
- (thread-sleep! 2)
(rmt:general-open-connection remote apath mdbname))
((not (rmt:get-conn remote apath dbname)) ;; no channel open to dbname?
(let* ((res (rmt:send-receive-real remote apath mdbname 'get-server `(,apath ,dbname))))
(case res
((server-started)
@@ -262,27 +265,60 @@
(begin
(debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname)
(exit 1))))
(else
(if (list? res) ;; server has been registered and the info was returned. pass it on.
- res
+ (begin ;; ("192.168.0.9" 53817
+ ;; "5e34239f48e8973b3813221e54701a01" "24310"
+ ;; "192.168.0.9"
+ ;; "/home/matt/data/megatest/tests/simplerun"
+ ;; ".db/1.db")
+ (match
+ res
+ ((host port servkey pid ipaddr apath dbname)
+ (debug:print-info 0 *default-log-port* "got "res)
+ (hash-table-set! (rmt:remote-conns remote)
+ dbname
+ (make-rmt:conn
+ apath: apath
+ dbname: dbname
+ hostport: (conc host":"port)
+ ipaddr: ipaddr
+ port: port
+ srvkey: servkey
+ lastmsg: (current-seconds)
+ expires: (+ (current-seconds) 60))))
+ (else
+ (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res)))
+ res)
(begin
(debug:print-info 0 *default-log-port* "Unexpected result: " res)
- res)))))))))
+ res))))))
+
+
+ )))
;;======================================================================
+;; FOR DEBUGGING SET TO #t
+(define *localmode* #t)
+(define *dbstruct* (make-dbr:dbstruct))
;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
(if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
- (let* ((apath *toppath*)
- (conns *rmt:remote*)
- (dbname (db:run-id->dbname rid)))
- (rmt:general-open-connection conns apath dbname)
- (rmt:send-receive-real conns apath dbname cmd params)))
+ (let* ((apath *toppath*)
+ (conns *rmt:remote*)
+ (dbname (db:run-id->dbname rid)))
+ (if *localmode*
+ (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname))
+ (indat `((cmd . ,cmd)(params . ,params))))
+ (api:process-request *dbstruct* indat))
+ (begin
+ (rmt:general-open-connection conns apath dbname)
+ (rmt:send-receive-real conns apath dbname cmd params)))))
#;(define (rmt:send-receive-setup conn)
(if (not (rmt:conn-inport conn))
(let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
(rmt:conn-port conn))))
@@ -293,31 +329,19 @@
;; sometime in the future
;;
(define (rmt:send-receive-real remote apath dbname cmd params)
(let* ((conn (rmt:get-conn remote apath dbname)))
(assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")
- (pp (rmt:conn->alist conn))
- ;; (rmt:send-receive-setup conn)
- (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
- (rmt:conn-port conn))))
- (let* ((key #f)
- (payload `((cmd . ,cmd)
- (key . ,(rmt:conn-srvkey conn))
- (params . ,params)))
- (res (begin
- (write payload o) ;; (rmt:conn-outport conn))
- (with-input-from-port
- i ;; (rmt:conn-inport conn)
- read))))
- (close-input-port i)
- (close-output-port o)
- res))))
-;; (if (string? res)
-;; (string->sexpr res)
-;; res))))
-
-
+ (let* ((key #f)
+ (host (rmt:conn-ipaddr conn))
+ (port (rmt:conn-port conn))
+ (payload `((cmd . ,cmd)
+ (key . ,(rmt:conn-srvkey conn))
+ (params . ,params)))
+ (res (open-send-receive-nn (conc host":"port)
+ (sexpr->string payload))))
+ (string->sexpr res))))
;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
@@ -332,11 +356,11 @@
;; read-string)))
;; (string->sexpr res))))
(define (rmt:print-db-stats)
(let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
- (debug:print 18 *default-log-port* "DB Stats\n========")
+ (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================")
(debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
(for-each (lambda (cmd)
(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
(debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
(sort (hash-table-keys *db-stats*)
@@ -677,12 +701,11 @@
;; first register in main.db (thus the #f)
(let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))))
;; now register in the run db itself
;; NEED A RECORD INSERT INCLUDING SETTING id
- (rmt:send-receive 'register-run run-id (list keyvals runname state status user contour))
-
+ (rmt:send-receive 'insert-run run-id (list run-id keyvals runname state status user contour))
run-id))
(define (rmt:get-run-name-from-id run-id)
(rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
@@ -738,27 +761,27 @@
) ;; )
(define (rmt:get-main-run-stats run-id)
(rmt:send-receive 'get-main-run-stats #f (list run-id)))
-(define (rmt:get-var varname)
- (rmt:send-receive 'get-var #f (list varname)))
-
-(define (rmt:del-var varname)
- (rmt:send-receive 'del-var #f (list varname)))
-
-(define (rmt:set-var varname value)
- (rmt:send-receive 'set-var #f (list varname value)))
-
-(define (rmt:inc-var varname)
- (rmt:send-receive 'inc-var #f (list varname)))
-
-(define (rmt:dec-var varname)
- (rmt:send-receive 'dec-var #f (list varname)))
-
-(define (rmt:add-var varname value)
- (rmt:send-receive 'add-var #f (list varname value)))
+(define (rmt:get-var run-id varname)
+ (rmt:send-receive 'get-var run-id (list run-id varname)))
+
+(define (rmt:del-var run-id varname)
+ (rmt:send-receive 'del-var run-id (list run-id varname)))
+
+(define (rmt:set-var run-id varname value)
+ (rmt:send-receive 'set-var run-id (list run-id varname value)))
+
+(define (rmt:inc-var run-id varname)
+ (rmt:send-receive 'inc-var #f (list run-id varname)))
+
+(define (rmt:dec-var run-id varname)
+ (rmt:send-receive 'dec-var run-id (list run-id varname)))
+
+(define (rmt:add-var run-id varname value)
+ (rmt:send-receive 'add-var run-id (list run-id varname value)))
;;======================================================================
;; M U L T I R U N Q U E R I E S
;;======================================================================
@@ -816,12 +839,13 @@
;;
;;(define (rmt:get-steps-for-test run-id test-id)
;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
- (let* ((state (items:check-valid-items "state" state-in))
- (status (items:check-valid-items "status" status-in)))
+ (let* ((valid-values (configf:lookup *configdat* "validvalues" "state"))
+ (state (items:check-valid-items valid-values "state" state-in))
+ (status (items:check-valid-items valid-values "status" status-in)))
(if (or (not state)(not status))
(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
@@ -1396,18 +1420,18 @@
;;======================================================================
;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
- (rmt:get-var "MEGATEST_VERSION"))
+ (rmt:get-var #f "MEGATEST_VERSION"))
(define (common:get-last-run-version-number)
(string->number
(substring (common:get-last-run-version) 0 6)))
(define (common:set-last-run-version)
- (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+ (rmt:set-var #f "MEGATEST_VERSION" (common:version-signature)))
;;======================================================================
;; faux-lock is deprecated. Please use simple-lock below
;;
(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
@@ -1443,10 +1467,57 @@
(common:version-signature))))
(define (common:api-changed?)
(not (equal? (substring (->string megatest-version) 0 4)
(substring (conc (common:get-last-run-version)) 0 4))))
+
+(define (rmt:server-shutdown)
+ (let ((dbfile (servdat-dbfile *server-info*)))
+ (debug:print-info 0 *default-log-port* "dbfile is "dbfile)
+ (if dbfile
+ (let* ((am-server (args:get-arg "-server"))
+ (dbfile (args:get-arg "-db"))
+ (apath *toppath*)
+ (dbdat (db:get-dbdat *dbstruct-db* apath dbfile))
+ (db (dbr:dbdat-db dbdat))
+ (inmem (dbr:dbdat-db dbdat))
+ )
+ ;; do a final sync here
+ (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds))
+ (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t)
+ ;; let's finalize here
+ (debug:print-info 0 *default-log-port* "Finalizing db and inmem")
+ (sqlite3:finalize! db)
+ (sqlite3:finalize! inmem)
+ (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete")
+ (if am-server
+ (if (string-match ".*/main.db$" dbfile)
+ (let ((pkt-file (conc (get-pkts-dir *toppath*)
+ "/" (servdat-uuid *server-info*)
+ ".pkt")))
+ (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
+ (delete-file* pkt-file)
+ (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
+ (db:with-lock-db (servdat-dbfile *server-info*)
+ (lambda (dbh dbfile)
+ (db:release-lock dbh dbfile))))
+ (let* ((sdat *server-info*) ;; we have a run-id server
+ (host (servdat-host sdat))
+ (port (servdat-port sdat))
+ (uuid (servdat-uuid sdat)))
+ (if (not (string-match ".db/main.db" (args:get-arg "-db")))
+ (let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*?
+ *toppath*
+ (servdat-host *server-info*) ;; iface
+ (servdat-port *server-info*)
+ (servdat-uuid *server-info*)
+ (current-process-id)
+ )))
+ (debug:print-info 0 *default-log-port* "deregistered-server, res="res)))
+
+ (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid)
+ )))))))
(define (std-exit-procedure)
;;(common:telemetry-log-close)
(on-exit (lambda () 0))
;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
@@ -1456,56 +1527,40 @@
(bdat-time-to-exit-set! *bdat* #t)
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats))
- (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *server-info*
- (let ((pkt-file (conc (get-pkts-dir *toppath*)
- "/" (servdat-uuid *server-info*)
- ".pkt"))
- (dbfile (servdat-dbfile *server-info*)))
- (if dbfile
- (begin
-
- ;; do a final sync here
-
- (if (string-match ".*/main.db$" dbfile)
- (begin
- (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
- (delete-file* pkt-file)
- (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
- (db:with-lock-db (servdat-dbfile *server-info*)
- (lambda (dbh dbfile)
- (db:release-lock dbh dbfile))))
- (let* ((sdat *server-info*)) ;; we have a run-id server
- (rmt:send-receive-real *rmt:remote* *toppath*
- (db:run-id->dbname #f)
- 'deregister-server
- `(,(servdat-uuid sdat)
- ,(current-process-id)
- ,(servdat-host sdat) ;; iface
- ,(servdat-port sdat)))))))))
- (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
- (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db
- (let ((db (cdr (bdat-task-db *bdat*))))
- (if (sqlite3:database? db)
- (begin
- (sqlite3:interrupt! db)
- (sqlite3:finalize! db #t)
- (bdat-task-db-set! *bdat* #f)))))
- #;(http-client#close-idle-connections!)
- (if (not (eq? *default-log-port* (current-error-port)))
- (close-output-port *default-log-port*))
- (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
+ (let ((th1 (make-thread
+ (lambda () ;; thread for cleaning up, give it five seconds
+ (let* ((start-time (current-seconds)))
+ (if (and *server-info*
+ *unclean-shutdown*)
+ (begin
+ (debug:print-info 0 *default-log-port* "Unclean server exit, calling server-shtudown")
+ (rmt:server-shutdown)))
+ (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds"))
+ ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
+ #;(if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db
+ (let ((db (cdr (bdat-task-db *bdat*))))
+ (if (sqlite3:database? db)
+ (begin
+ (debug:print-info 0 *default-log-port* "Closing down task db "db)
+ (sqlite3:interrupt! db)
+ (sqlite3:finalize! db #t)
+ (bdat-task-db-set! *bdat* #f)))))
+ #;(http-client#close-idle-connections!)
+ (if (not (eq? *default-log-port* (current-error-port)))
+ (close-output-port *default-log-port*))
+ (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
(th2 (make-thread (lambda ()
- (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
+ (debug:print 4 *default-log-port* "Attempting clean exit. Mode="(if no-hurry "no-hurry" "normal")
+ " Please be patient and wait a few seconds...")
(if no-hurry
(begin
(thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
(begin
- (thread-sleep! 2)))
+ (thread-sleep! 2)))
(debug:print 4 *default-log-port* " ... done")
)
"clean exit")))
(thread-start! th1)
(thread-start! th2)
@@ -1539,38 +1594,13 @@
;;======================================================================
;; S E R V E R
;; ======================================================================
-;; NOTE: http-transport:launch is the entry point
-;; -> http-transport:run
-;; -> http-transport:try-start-server -> http-transport:try-start-server (until success)
-
(define (http-get-function fnkey)
(hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))
-#;(define (rmt:launch-server hostn port)
- (if *server-info*
- (begin
- (servdat-host-set! *server-info* hostn)
- (servdat-port-set! *server-info* port)
- (servdat-status-set! *server-info* 'trying-port)
- (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
- (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
- (let* ((l (tcp-listen port))
- (dbstruct #f))
- (let-values (((i o) (tcp-accept l)))
- ;; (write-line "Hello!" o)
- (let loop ((indat (read i)))
- (let* ((res (api:process-request dbstruct indat)))
- (case res
- ((quit)
- (close-input-port i)
- (close-output-port o))
- (else
- (write res o))))))))
-
(define (rmt:run hostn)
;; ;; Configurations for server
;; (tcp-buffer-size 2048)
;; (max-connections 2048)
(debug:print 2 *default-log-port* "Attempting to start the server ...")
@@ -1581,73 +1611,111 @@
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (common:get-linktree))
- (tmp-area (common:get-db-tmp-area))
+ ;; (tmp-area (common:get-db-tmp-area))
#;(start-file (conc tmp-area "/.server-start")))
(debug:print-info 0 *default-log-port* "portlogger recommended port: " port)
(if *server-info*
(begin
(servdat-host-set! *server-info* ipaddrstr)
(servdat-port-set! *server-info* port)
(servdat-status-set! *server-info* 'trying-port)
(servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
(set! *server-info* (make-servdat host: ipaddrstr port: port)))
- (let* ((l (rmt:try-start-server ipaddrstr port)))
- (let oloop ()
- (let-values (((i o) (tcp-accept l)))
- ;; (write-line "Hello!" o)
- (let loop ((indat (read i)))
- (if (eof-object? indat)
- (begin
- (close-input-port i)
- (close-output-port o)
- (oloop))
- (let* ((res (api:process-request *dbstruct-db* indat)))
- (set! *db-last-access* (current-seconds))
- (write res o)
- (loop (read i))))))))
+ (let* ((rep (rmt:try-start-server ipaddrstr port)))
+ (let loop ((instr (nng-recv rep)))
+ (let* ((data (string->sexpr instr))
+ (res (case data
+ ((quit) 'quit)
+ (else (api:process-request *dbstruct-db* data))))
+ (resdat (sexpr->string res)))
+ (if (not (eq? res 'quit))
+ (begin
+ (set! *db-last-access* (current-seconds))
+ (nng-send rep resdat)
+ (loop (nng-recv rep)))))))
+ (debug:print-info 0 *default-log-port* "After server, should never see this")
+ ;; server exit stuff here
(let* ((portnum (servdat-port *server-info*)))
(portlogger:open-run-close portlogger:set-port portnum "released")
- (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
+ (rmt:server-shutdown)
+ ;; (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up
+ (portlogger:open-run-close portlogger:set-port port "released") ;; done in rmt:run
+ ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
+ ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
+ ;; (debug:print-info 0 *default-log-port* "Average cached write time "
+ ;; (if (eq? *number-of-writes* 0)
+ ;; "n/a (no writes)"
+ ;; (/ *writes-total-delay*
+ ;; *number-of-writes*))
+ ;; " ms")
+ ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
+ ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
+ ;; (if (eq? *number-non-write-queries* 0)
+ ;; "n/a (no queries)"
+ ;; (/ *total-non-write-delay*
+ ;; *number-non-write-queries*))
+ ;; " ms")
+
+ (db:print-current-query-stats)
+ (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
+ )))
(define (rmt:try-start-server ipaddrstr portnum)
- (if *server-info*
+ (if *server-info* ;; update the server info as we might be trying next port
(begin
(servdat-host-set! *server-info* ipaddrstr)
(servdat-port-set! *server-info* portnum)
(servdat-status-set! *server-info* 'trying-port)
- (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
+ (servdat-trynum-set! *server-info*
+ (+ (servdat-trynum *server-info*) 1)))
(set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
(debug:print-info 0 *default-log-port* "rmt:try-start-server time="
(seconds->time-string (current-seconds))
" ipaddrsstr=" ipaddrstr
" portnum=" portnum)
- (handle-exceptions
- exn
- (begin
- (print-error-message exn)
- (if (< portnum 64000)
- (begin
- (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (portlogger:open-run-close portlogger:set-failed portnum)
- (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
- ;; (thread-sleep! 0.1)
- (rmt:try-start-server ipaddrstr
- (portlogger:open-run-close portlogger:find-port)))
- (begin
- (print "ERROR: Tried and tried but could not start the server"))))
- ;; any error in following steps will result in a retry
- (if *server-info*
- (servdat-status-set! *server-info* 'starting)
- (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
-
- (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
- (tcp-listen portnum)))
+ (if (is-port-in-use portnum)
+ (begin
+ (portlogger:open-run-close portlogger:set-failed portnum)
+ (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
+ ;; (thread-sleep! 0.1)
+ (rmt:try-start-server ipaddrstr
+ (portlogger:open-run-close
+ portlogger:find-port)))
+ (begin
+ (if (not *server-info*)
+ (set! *server-info* (make-servdat
+ host: ipaddrstr
+ port: portnum)))
+ (servdat-status-set! *server-info* 'starting)
+ (servdat-port-set! *server-info* portnum)
+ (if (not (servdat-rep *server-info*))
+ (let ((rep (make-rep-socket)))
+ (servdat-rep-set! *server-info* rep)
+ (socket-set! rep 'nng/recvtimeo 2000)))
+ (let* ((rep (servdat-rep *server-info*)))
+ (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
+ (handle-exceptions
+ exn
+ (begin
+ (print-error-message exn)
+ (if (< portnum 64000)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (portlogger:open-run-close portlogger:set-failed portnum)
+ (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
+ ;; (thread-sleep! 0.1)
+ (rmt:try-start-server ipaddrstr
+ (portlogger:open-run-close portlogger:find-port)))
+ (begin
+ (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum))))
+ (nng-listen rep (conc "tcp://*:" portnum))
+ rep)))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
@@ -1796,31 +1864,33 @@
(define (server-address srv-pkt)
(conc (alist-ref 'host srv-pkt) ":"
(alist-ref 'port srv-pkt)))
(define (server-ready? host port key) ;; server-address is host:port
- (let-values (((i o)(handle-exceptions
- exn
- (values #f #f)
- (tcp-connect host port))))
- (if (and i o)
- (begin
- (write `((cmd . ping)
- (key . ,key)
- (params . ())) o)
- (let ((res (with-input-from-port i
- read)))
- (close-output-port o)
- (close-input-port i)
- res))
+;; (let-values (((i o)(handle-exceptions
+;; exn
+;; (values #f #f)
+;; (tcp-connect host port))))
+;; (if (and i o)
+ (let* ((data (sexpr->string `((cmd . ping)
+ (key . ,key)
+ (params . ()))))
+ (res (open-send-receive-nn (conc host ":" port) data)))
+ (string->sexpr res)))
+
+;; (let ((res (with-input-from-port i
+;; read)))
+;; (close-output-port o)
+;; (close-input-port i)
+;; res))
;; (if (string? res)
;; (string->sexpr res)
;; res)))
- (begin ;; connection failed
- (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
- #f))))
-
+;; (begin ;; connection failed
+;; (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
+;; #f))))
+
;; (define (loop-test host port data) ;; server-address is host:port
;; ;; ping the server and ask it
;; ;; if it ready
;; ;; (let* ((sdat (servdat-init #f host port #f)))
;; ;; (http-transport:send-receive sdat "abc" 'ping '())))
@@ -1970,18 +2040,38 @@
(equal? sdat last-sdat)
sdat))))))))
(define (rmt:register-server remote apath iface port server-key dbname)
(rmt:open-main-connection remote apath) ;; we need a channel to main.db
- (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
- (db:run-id->dbname #f) 'register-server `(,iface
- ,port
- ,server-key
- ,(current-process-id)
- ,iface
- ,apath
- ,dbname)))
+ (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'register-server `(,iface
+ ,port
+ ,server-key
+ ,(current-process-id)
+ ,iface
+ ,apath
+ ,dbname)))
+
+(define (rmt:get-count-servers remote apath)
+ (rmt:open-main-connection remote apath) ;; we need a channel to main.db
+ (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'get-count-servers `(,apath
+ )))
+
+(define (rmt:deregister-server remote apath iface port server-key dbname)
+ (rmt:open-main-connection remote apath) ;; we need a channel to main.db
+ (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'deregister-server `(,iface
+ ,port
+ ,server-key
+ ,(current-process-id)
+ ,iface
+ ,apath
+ ,dbname)))
(define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100))
;; wait until *server-info* stops changing
(let* ((stime (current-seconds)))
(let loop ((last-host #f)
@@ -2040,15 +2130,16 @@
(http-transport:wait-for-server pkts-dir dbname server-key)
(http-transport:wait-for-stable-interface))
;; this is our forever loop
(let* ((iface (servdat-host *server-info*))
(port (servdat-port *server-info*)))
- (let loop ((count 0)
+ (let loop ((count 0)
(bad-sync-count 0)
(start-time (current-milliseconds)))
- (if (not is-main)
+ (if (and (not is-main)
+ (common:low-noise-print 60 "servdat-status"))
(debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*)))
;; set up the database handle
(mutex-lock! *heartbeat-mutex*)
(if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
@@ -2068,20 +2159,28 @@
(exit)))))
(debug:print 0 *default-log-port*
"SERVER: running, db "dbname" opened, megatest version: "
(common:get-full-version))
;; start the watchdog
- (if watchdog
+
+ ;; is this really needed?
+
+ #;(if watchdog
(if (not (member (thread-state watchdog)
'(ready running blocked
sleeping dead)))
(begin
(debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")")
(thread-start! watchdog))
(debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")"))
(debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))
- #;(loop (+ count 1) bad-sync-count start-time)))
+ #;(loop (+ count 1) bad-sync-count start-time)
+ ))
+
+ (debug:print-info 0 *default-log-port* "syncing "*toppath*" "dbname" at "(current-seconds))
+ (db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t)
+
(mutex-unlock! *heartbeat-mutex*)
;; when things go wrong we don't want to be doing the various
;; queries too often so we strive to run this stuff only every
;; four seconds or so.
@@ -2103,64 +2202,37 @@
(db:print-current-query-stats)))
(let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
(cond
((and *server-run*
(> (+ last-access server-timeout)
- (current-seconds)))
+ (current-seconds))
+ (if is-main
+ (> (rmt:get-count-servers *rmt:remote* *toppath*) 1)
+ #t))
(if (common:low-noise-print 120 "server continuing")
(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
(loop 0 bad-sync-count (current-milliseconds)))
(else
+ (set! *unclean-shutdown* #f)
(debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
- (http-transport:server-shutdown port))))))))
-
-(define (http-transport:server-shutdown port)
- (begin
- ;;(BB> "http-transport:server-shutdown called")
- (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
- ;;
- ;; start_shutdown
- ;;
-
- ;; deregister the server
-
-
- (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up
- (portlogger:open-run-close portlogger:set-port port "released")
- (thread-sleep! 1)
-
- ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
- ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
- ;; (debug:print-info 0 *default-log-port* "Average cached write time "
- ;; (if (eq? *number-of-writes* 0)
- ;; "n/a (no writes)"
- ;; (/ *writes-total-delay*
- ;; *number-of-writes*))
- ;; " ms")
- ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
- ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
- ;; (if (eq? *number-non-write-queries* 0)
- ;; "n/a (no queries)"
- ;; (/ *total-non-write-delay*
- ;; *number-non-write-queries*))
- ;; " ms")
-
- (db:print-current-query-stats)
- (common:save-pkt `((action . exit)
- (T . server)
- (pid . ,(current-process-id)))
- *configdat* #t)
- (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
- (exit)))
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
+ (rmt:server-shutdown)
+ (portlogger:open-run-close portlogger:set-port port "released")
+ (exit)
+ #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: "
+ (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown
+ (sexpr->string 'quit)))
+ )))))))
;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; This is the point at which servers are started
;;
(define (rmt:server-launch dbname)
+ (debug:print-info 0 *default-log-port* "Entered rmt:server-launch")
(let* ((th2 (make-thread (lambda ()
(debug:print-info 0 *default-log-port* "Server run thread started")
(rmt:run (if (args:get-arg "-server")
(args:get-arg "-server")
"-")
@@ -2172,12 +2244,13 @@
(thread-start! th2)
(thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th2)
- (exit))
-
+ (thread-join! th3)
+ ;; (exit))
+ )
#f
)
;; Generate a unique signature for this process, used at both client and
;; server side
@@ -2192,10 +2265,112 @@
(define (rmt:get-signature)
(if *my-signature* *my-signature*
(let ((sig (rmt:mk-signature)))
(set! *my-signature* sig)
*my-signature*)))
+
+;;======================================================================
+;; Nanomsg transport
+;;======================================================================
+
+(define (is-port-in-use port-num)
+ (let* ((ret #f))
+ (let-values (((inp oup pid)
+ (process "netstat" (list "-tulpn" ))))
+ (let loop ((inl (read-line inp)))
+ (if (not (eof-object? inl))
+ (begin
+ (if (string-search (regexp (conc ":" port-num)) inl)
+ (begin
+ ;(print "Output: " inl)
+ (set! ret #t))
+ (loop (read-line inp)))))))
+ ret))
+
+;;start a server, returns the connection
+;;
+(define (start-nn-server portnum )
+ (let ((rep (make-rep-socket))) ;; (nn-socket 'rep)))
+ (socket-set! rep 'nng/recvtimeo 2000)
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ (print "ERROR: Failed to start server \"" emsg "\"")
+ (exit 1))
+
+ (nng-dial #;nn-bind rep (conc "tcp://*:" portnum)))
+ rep))
+
+;; open connection to server, send message, close connection
+;;
+(define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
+ (let ((req (make-req-socket 'req))
+ (uri (conc "tcp://" host-port))
+ (res #f)
+ ;; (contacts (alist-ref 'contact attrib))
+ ;; (mode (alist-ref 'mode attrib))
+ )
+ (socket-set! req 'nng/recvtimeo 2000)
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ ;; Send notification
+ (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
+ #f)
+ (nng-dial req uri)
+ ;; (print "Connected to the server " )
+ (nng-send req msg)
+ ;; (print "Request Sent")
+ (let* ((th1 (make-thread (lambda ()
+ (let ((resp (nng-recv req)))
+ (nng-close! req)
+ (set! res (if (equal? resp "ok")
+ #t
+ #f))))
+ "recv thread"))
+ (th2 (make-thread (lambda ()
+ (thread-sleep! timeout)
+ (thread-terminate! th1))
+ "timer thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ res))))
+
+(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
+ (let ((req (make-req-socket))
+ (uri (conc "tcp://" host-port))
+ (res #f)
+ ;; (contacts (alist-ref 'contact attrib))
+ ;; (mode (alist-ref 'mode attrib))
+ )
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ ;; Send notification
+ (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn)
+ #f)
+ (nng-dial req uri)
+ ;; (print "Connected to the server " )
+ (nng-send req msg)
+ ;; (print "Request Sent")
+ ;; receive code here
+ ;;(print (nn-recv req))
+ (let* ((th1 (make-thread (lambda ()
+ (let ((resp (nng-recv req)))
+ (nng-close! req)
+ (print resp)
+ (set! res resp)))
+ "recv thread"))
+ (th2 (make-thread (lambda ()
+ (thread-sleep! timeout)
+ (thread-terminate! th1))
+ "timer thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ res))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -298,11 +298,11 @@
#f ;; get full data (not 'shortlist)
0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
'dashboard)
'()))
(log-dir (conc *toppath* "/logs"))
- (log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
+ (log-file (conc "pre-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log"))
(full-log-fname (conc log-dir "/" log-file)))
(if run-pre-hook
(if (null? existing-tests)
(let* ((use-log-dir (if (not (directory-exists? log-dir))
(handle-exceptions
@@ -345,11 +345,11 @@
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name)))
;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
- (dbfile (conc *toppath* "/megatest.db"))
+ (dbfile (conc *toppath* "/.db/main.db"))
(readonly-mode (not (file-writable? dbfile)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
@@ -498,19 +498,19 @@
;; run the run prehook if there are no tests yet run for this run:
;;
(runs:run-pre-hook run-id)
;; mark all test launched flag as false in the meta table
- (rmt:set-var (conc "lunch-complete-" run-id) "no")
+ (rmt:set-var run-id (conc "lunch-complete-" run-id) "no")
(debug:print-info 1 *default-log-port* "Setting end-of-run to no")
(let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
(config-rerun-cnt (if config-reruns
config-reruns
1)))
(if (eq? config-rerun-cnt run-count)
- (rmt:set-var (conc "end-of-run-" run-id) "no")))
+ (rmt:set-var run-id (conc "end-of-run-" run-id) "no")))
(rmt:set-run-state-status run-id "new" "n/a")
;; now add non-directly referenced dependencies (i.e. waiton)
;;======================================================================
;; refactoring this block into tests:get-full-data
@@ -522,11 +522,11 @@
(if (not (null? test-names)) ;; BEGIN test-names loop
(let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
- (setenv "MT_TEST_NAME" hed) ;;
+ (set-environment-variable! "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry))
;; NOTE: Have the config - can extract [waitons] section
((hed-mode)
@@ -813,12 +813,12 @@
(and (member 'toplevel testmode)
(null? non-completed)))
(debug:print-info 4 *default-log-port* "cond branch - " "ei-2")
(debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
(let ((test-name (tests:testqueue-get-testname test-record)))
- (setenv "MT_TEST_NAME" test-name) ;;
- (setenv "MT_RUNNAME" runname)
+ (set-environment-variable! "MT_TEST_NAME" test-name) ;;
+ (set-environment-variable! "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
(let ((items-list (items:get-items-from-config tconfig)))
(if (list? items-list)
(begin
(if (null? items-list)
@@ -1705,11 +1705,11 @@
(else
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-9")
(debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
))) ;; end loop on sorted test names
;; this is the point where everything is launched and now you can mark the run in metadata table as all launched
- (rmt:set-var (conc "lunch-complete-" run-id) "yes")
+ (rmt:set-var run-id (conc "lunch-complete-" run-id) "yes")
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
(thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
@@ -1827,13 +1827,13 @@
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)
- ;; (setenv "MT_TEST_NAME" test-name) ;;
- ;; (setenv "MT_ITEMPATH" item-path)
- ;; (setenv "MT_RUNNAME" runname)
+ ;; (set-environment-variable! "MT_TEST_NAME" test-name) ;;
+ ;; (set-environment-variable! "MT_ITEMPATH" item-path)
+ ;; (set-environment-variable! "MT_RUNNAME" runname)
(change-directory *toppath*)
;; Here is where the test_meta table is best updated
;; Yes, another use of a global for caching. Need a better way?
;;
@@ -2740,17 +2740,17 @@
(process-signal pid signal/int)
(thread-sleep! 5)
(if (process:alive? pid)
(process-signal pid signal/kill)))))
;; (call-with-environment-variables
- (let ((old-targethost (getenv "TARGETHOST")))
- (setenv "TARGETHOST" hostname)
- (setenv "TARGETHOST_LOGF" "server-kills.log")
+ (let ((old-targethost (get-environment-variable "TARGETHOST")))
+ (set-environment-variable! "TARGETHOST" hostname)
+ (set-environment-variable! "TARGETHOST_LOGF" "server-kills.log")
(system (conc "nbfake kill " pid))
- (if old-targethost (setenv "TARGETHOST" old-targethost))
- (unsetenv "TARGETHOST")
- (unsetenv "TARGETHOST_LOGF"))))
+ (if old-targethost (set-environment-variable! "TARGETHOST" old-targethost))
+ (unset-environment-variable! "TARGETHOST")
+ (unset-environment-variable! "TARGETHOST_LOGF"))))
(debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
records)))
(define (task:get-run-times)
(let* (
DELETED server.scm
Index: server.scm
==================================================================
--- server.scm
+++ /dev/null
@@ -1,51 +0,0 @@
-;; Copyright 2006-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 .
-;;
-
-;; (require-extension (srfi 18) extras tcp s11n)
-;;
-;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
-;; directory-utils posix-extras matchable)
-;;
-;; (use spiffy uri-common intarweb http-client spiffy-request-vars)
-;;
-;; (declare (unit server))
-;;
-;; (declare (uses common))
-;; (declare (uses db))
-;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-;; ;; (declare (uses synchash))
-;; (declare (uses http-transport))
-;; ;;(declare (uses rpc-transport))
-;; (declare (uses launch))
-;; ;; (declare (uses daemon))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
Index: tests/unittests/basicserver.scm
==================================================================
--- tests/unittests/basicserver.scm
+++ tests/unittests/basicserver.scm
@@ -63,11 +63,11 @@
;; (rmt:conn-port *main*) tdat)))
;; (list 'a
;; '(a "b" 123 1.23 )))
(test #f #t (rmt:send-receive 'ping #f 'hello))
-(define *db* (db:setup #f))
+(define *db* (db:setup ".db/main.db"))
;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
Index: tests/unittests/server.scm
==================================================================
--- tests/unittests/server.scm
+++ tests/unittests/server.scm
@@ -32,490 +32,51 @@
;; rmt:send-receive-real
;; rmt:send-receive
;; sexpr->string
;; server-ready?
;; rmt:register-server
+ ;; rmt:deregister-server
;; rmt:open-main-connection
;; rmt:general-open-connection
- ;; rmt:get-conny
+ ;; rmt:get-conn
;; common:watchdog
;; rmt:find-main-server
;; get-all-server-pkts
;; get-viable-servers
;; get-best-candidate
;; api:run-server-process
+ ;; api:process-request
;; rmt:run
;; rmt:try-start-server
)
-(define *db* (db:setup #f))
+(define *db* (db:setup ".db/main.db"))
;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
(define keyvals '(("SYSTEM" "a")("RELEASE" "b")))
(test #f #t (rmt:open-main-connection remote apath))
+(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname)))
(thread-sleep! 2)
(test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db")))
(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
(test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f)))
(print "Got here.")
-(test #t 1 (rmt:send-receive 'register-run 1 (list keyvals "run2" "new" "n/a" "justme" #f)))
-
-(test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))
-
-;; (delete-file* "logs/1.log")
-;; (define run-id 1)
-
-;; (test "setup for run" #t (begin (launch:setup)
-;; (string? (getenv "MT_RUN_AREA_HOME"))))
-;;
-;; (test #f #t (and (server:kind-run *toppath*) #t))
-;;
-;;
-;; (define user (current-user-name))
-;; (define runname "mytestrun")
-;; (define keys (rmt:get-keys))
-;; (define runinfo #f)
-;; (define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
-;; (define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
-;;
-;; ;; Setup
-;; ;;
-;; ;; (test #f #f (not (client:setup run-id)))
-;; ;; (test #f #f (not (hash-table-ref/default *runremote* run-id #f)))
-;;
-;; ;; Login
-;; ;;
-;; (test #f'(#t "successful login")
-;; (rmt:login run-id))
-;;
-;; ;; Keys
-;; ;;
-;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
-;;
-;; ;; No data in db
-;; ;;
-;; (test #f '() (rmt:get-all-run-ids))
-;; (test #f #f (rmt:get-run-name-from-id run-id))
-;; (test #f
-;; (vector
-;; header
-;; (vector #f #f #f #f))
-;; (rmt:get-run-info run-id))
-;;
-;; ;; Insert data into db
-;; ;;
-;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
-;; ;; (test #f #f (rmt:get-runs-by-patt keys runname))
-;; (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
-;; (define test-one-id #f)
-;; (test #f 1 (let ((test-id (rmt:get-test-id run-id "test-one" "")))
-;; (set! test-one-id test-id)
-;; test-id))
-;; (define test-one-rec #f)
-;; (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
-;; (set! test-one-rec test-rec)
-;; (vector-ref test-rec 2)))
-;;
-;; ;; With data in db
-;; ;;
-;; (print "Using runame=" runname)
-;; (test #f '(1) (rmt:get-all-run-ids))
-;; (test #f runname (rmt:get-run-name-from-id run-id))
-;; (test #f
-;; runname
-;; (let ((run-info (rmt:get-run-info run-id)))
-;; (db:get-value-by-header (db:get-rows run-info)
-;; (db:get-header run-info)
-;; "runname")))
-;;
-;; ;; test killing server
-;; ;;
-;; (for-each
-;; (lambda (run-id)
-;; (test #f #t (and (tasks:kill-server-run-id run-id) #t))
-;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)))
-;; (list 0 1))
-;;
-;; ;; Tests to assess reading/writing while servers are starting/stopping
-;; ;; NO LONGER APPLICABLE
-;;
-;; ;; Server tests go here
-;; (define (server-tests-dont-run-right-now)
-;; (for-each
-;; (lambda (run-id)
-;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
-;; (server:kind-run run-id)
-;; (test "did server start within 20 seconds?"
-;; #t
-;; (let loop ((remtries 20)
-;; (running (tasks:server-running-or-starting? (db:delay-if-busy
-;; (tasks:open-db))
-;; run-id)))
-;; (if running
-;; (> running 0)
-;; (if (> remtries 0)
-;; (begin
-;; (thread-sleep! 1)
-;; (loop (- remtries 1)
-;; (tasks:server-running-or-starting? (db:delay-if-busy
-;; (tasks:open-db))
-;; run-id)))))))
-;;
-;; (test "did server become available" #t
-;; (let loop ((remtries 10)
-;; (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
-;; (if res
-;; (vector? res)
-;; (begin
-;; (if (> remtries 0)
-;; (begin
-;; (thread-sleep! 1.1)
-;; (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
-;; res)))))
-;; )
-;; (list 0 1)))
-;;
-;; (define start-time (current-seconds))
-;; (define (reading-writing-while-server-starting-stopping-dont-run-now)
-;; (let loop ((test-state 'start))
-;; (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
-;; (first-dat (if (not (null? server-dats))
-;; (car server-dats)
-;; #f)))
-;; (map (lambda (dat)
-;; (apply print (intersperse (vector->list dat) ", ")))
-;; server-dats)
-;; (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
-;; (thread-sleep! 1)
-;; (case test-state
-;; ((start)
-;; (print "Trying to start server")
-;; (server:kind-run run-id)
-;; (loop 'server-started))
-;; ((server-started)
-;; (case (if first-dat (vector-ref first-dat 0) 'blah)
-;; ((running)
-;; (print "Server appears to be running. Now ask it to shutdown")
-;; (rmt:kill-server run-id)
-;; (loop 'server-shutdown))
-;; ((shutting-down)
-;; (loop test-state))
-;; (else (print "Don't know what to do if get here"))))
-;; ((server-shutdown)
-;; (loop test-state)))))
-;; )
-
-;;======================================================================
-;; END OF TESTS
-;;======================================================================
-
-
-;; (test #f #f (client:setup run-id))
-
-;; (set! *transport-type* 'http)
-;;
-;; (test "setup for run" #t (begin (launch:setup-for-run)
-;; (string? (getenv "MT_RUN_AREA_HOME"))))
-;;
-;; (test "server-register, get-best-server" #t (let ((res #f))
-;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
-;; (set! res (open-run-close tasks:get-best-server tasks:open-db))
-;; (number? (vector-ref res 3))))
-;;
-;; (test "de-register server" #f (let ((res #f))
-;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
-;; (vector? (open-run-close tasks:get-best-server tasks:open-db))))
-;;
-;; (define server-pid #f)
-;;
-;; ;; Not sure how the following should work, replacing it with system of megatest -server
-;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
-;; ;; ;; (daemon:ize)
-;; ;; (server:launch 'http)))))
-;; ;; (set! server-pid pid)
-;; ;; (number? pid)))
-;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &")
-;;
-;; (let loop ((n 10))
-;; (thread-sleep! 1) ;; need to wait for server to start.
-;; (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
-;; (print "tasks:get-best-server returned " res)
-;; (if (and (not res)
-;; (> n 0))
-;; (loop (- n 1)))))
-;;
-;; (test "get-best-server" #t (begin
-;; (client:launch)
-;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
-;; (vector? dat))))
-;;
-;; (define *keys* (keys:config-get-fields *configdat*))
-;; (define *keyvals* (keys:target->keyval *keys* "a/b/c"))
-;;
-;; (test #f #t (string? (car *runremote*)))
-;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
-;;
-;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test
-;;
-;; ;; RUNS
-;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name)))
-;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1)))
-;; (vector-ref (vector-ref rinfo 1) 3)))
-;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
-;;
-;; ;; TESTS
-;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
-;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" ""))
-;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
-;; (test "get test id" 1 (rmt:get-test-id 1 "test1" ""))
-;; (test "sync back" #t (> (rmt:sync-inmem->db) 0))
-;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
-;; (test "get keys" #t (list? (rmt:get-keys)))
-;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
-;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
-;; (db:test-get-comment trec)))
-;;
-;; ;; MORE RUNS
-;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '()))
-;; (header (vector-ref runs 0))
-;; (data (vector-ref runs 1)))
-;; (and (list? header)
-;; (list? data)
-;; (vector? (car data)))))
-;;
-;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
-;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))
-;;
-;; ;;======================================================================
-;; ;; D B
-;; ;;======================================================================
-;;
-;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
-;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
-;; (+ (db:test-get-pass_count dat)
-;; (db:test-get-fail_count dat))))
-;;
-;; (define testregistry (make-hash-table))
-;; (for-each
-;; (lambda (tname)
-;; (for-each
-;; (lambda (itempath)
-;; (let ((tkey (conc tname "/" itempath))
-;; (rpass (random 10))
-;; (rfail (random 10)))
-;; (hash-table-set! testregistry tkey (list tname itempath))
-;; (rmt:general-call 'register-test 1 tname itempath)
-;; (let* ((tid (rmt:get-test-id 1 tname itempath))
-;; (tdat (rmt:get-test-info-by-id tid)))
-;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
-;; (let* ((resdat (rmt:get-test-info-by-id tid)))
-;; (test "set/get pass fail counts" (list rpass rfail)
-;; (list (db:test-get-pass_count resdat)
-;; (db:test-get-fail_count resdat)))))))
-;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
-;; (list "test1" "test2" "test3" "test4" "test5"))
-;;
-;;
-;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
-;;
+
+(test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f)))
+
+(test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))
+;; (test #f 2 (rmt:deregister-server *rmt:remote* *toppath* iface port server-key dbname
+
+(test #f 2 (rmt:get-count-servers *rmt:remote* *toppath*))
+
+(test #f "run2" (rmt:get-run-name-from-id 2))
;; (exit)
-
-;; all old stuff below
-
-
-
-
-(delete-file* "logs/1.log")
-(define run-id 1)
-
-(test "setup for run" #t (begin (launch:setup-for-run)
- (string? (getenv "MT_RUN_AREA_HOME"))))
-
-;; Insert data into db
-;;
-(define user (current-user-name))
-(define runname "mytestrun")
-(define keys (rmt:get-keys))
-(define runinfo #f)
-(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
-(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
-
-(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
-;; (test #f #f (rmt:get-runs-by-patt keys runname))
-(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
-(define test-one-id #f)
-(test #f 30001 (let ((test-id (rmt:get-test-id run-id "test-one" "")))
- (set! test-one-id test-id)
- test-id))
-(define test-one-rec #f)
-(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
- (set! test-one-rec test-rec)
- (vector-ref test-rec 2)))
-
-(use trace)
-(import trace)
-;; (trace
-;; rmt:send-receive
-;; rmt:open-qry-close-locally
-;; )
-
-;; Tests to assess reading/writing while servers are starting/stopping
-(define start-time (current-seconds))
-(let loop ((test-state 'start))
- (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
- (first-dat (if (not (null? server-dats))
- (car server-dats)
- #f))
- (server-state (or (and first-dat (string->symbol (vector-ref first-dat 8))) 'no-dat)))
- (if first-dat
- (map (lambda (dat)
- (apply print (intersperse (vector->list dat) ", ")))
- server-dats)
- (print "No server"))
- (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
- (thread-sleep! 1)
- (case test-state
- ((start)
- (print "Trying to start server")
- (server:kind-run run-id)
- (loop 'server-started))
- ((server-started)
- (case server-state
- ((running)
- (print "Server appears to be running. Now ask it to shutdown")
- (rmt:kill-server run-id)
- ;; (trace rmt:open-qry-close-locally rmt:send-receive)
- (loop 'shutdown-started))
- ((available)
- (loop test-state))
- ((shutting-down)
- (loop test-state))
- ((no-dat)
- (loop test-state))
- (else (print "Don't know what to do if get here"))))
- ((shutdown-started)
- (case server-state
- ((no-dat)
- (print "Server appears to have shutdown, ending this test"))
- (else
- (loop test-state)))))))
-
-(exit)
-
-;; (set! *transport-type* 'http)
-;;
-;; (test "setup for run" #t (begin (setup-for-run)
-;; (string? (getenv "MT_RUN_AREA_HOME"))))
-;;
-;; (test "server-register, get-best-server" #t (let ((res #f))
-;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
-;; (set! res (open-run-close tasks:get-best-server tasks:open-db))
-;; (number? (vector-ref res 3))))
-;;
-;; (test "de-register server" #f (let ((res #f))
-;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
-;; (vector? (open-run-close tasks:get-best-server tasks:open-db))))
-;;
-;; (define server-pid #f)
-;;
-;; ;; Not sure how the following should work, replacing it with system of megatest -server
-;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
-;; ;; ;; (daemon:ize)
-;; ;; (server:launch 'http)))))
-;; ;; (set! server-pid pid)
-;; ;; (number? pid)))
-;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
-;;
-;; (let loop ((n 10))
-;; (thread-sleep! 1) ;; need to wait for server to start.
-;; (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
-;; (print "tasks:get-best-server returned " res)
-;; (if (and (not res)
-;; (> n 0))
-;; (loop (- n 1)))))
-;;
-;; (test "get-best-server" #t (begin
-;; (client:launch)
-;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
-;; (vector? dat))))
-;;
-;; (define *keys* (keys:config-get-fields *configdat*))
-;; (define *keyvals* (keys:target->keyval *keys* "a/b/c"))
-;;
-;; (test #f #t (string? (car *runremote*)))
-;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
-;;
-;; (test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test
-;;
-;; ;; RUNS
-;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name)))
-;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1)))
-;; (vector-ref (vector-ref rinfo 1) 3)))
-;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
-;;
-;; ;; TESTS
-;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
-;; (test "register test" #t (rmt:general-call 'register-test 1 1 "test1" ""))
-;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
-;; (test "get test id" 1 (rmt:get-test-id 1 "test1" ""))
-;;
-;; (test "sync back" #t (> (rmt:sync-inmem->db) 0))
-;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
-;;
-;; (test "get keys" #t (list? (rmt:get-keys)))
-;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t))
-;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1)))
-;; (db:test-get-comment trec)))
-;;
-;; ;; MORE RUNS
-;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '()))
-;; (header (vector-ref runs 0))
-;; (data (vector-ref runs 1)))
-;; (and (list? header)
-;; (list? data)
-;; (vector? (car data)))))
-;;
-;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2))
-;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2))
-;;
-;; ;;======================================================================
-;; ;; D B
-;; ;;======================================================================
-;;
-;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
-;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
-;; (+ (db:test-get-pass_count dat)
-;; (db:test-get-fail_count dat))))
-;;
-;; (define testregistry (make-hash-table))
-;; (for-each
-;; (lambda (tname)
-;; (for-each
-;; (lambda (itempath)
-;; (let ((tkey (conc tname "/" itempath))
-;; (rpass (random 10))
-;; (rfail (random 10)))
-;; (hash-table-set! testregistry tkey (list tname itempath))
-;; (rmt:general-call 'register-test 1 tname itempath)
-;; (let* ((tid (rmt:get-test-id 1 tname itempath))
-;; (tdat (rmt:get-test-info-by-id tid)))
-;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
-;; (let* ((resdat (rmt:get-test-info-by-id tid)))
-;; (test "set/get pass fail counts" (list rpass rfail)
-;; (list (db:test-get-pass_count resdat)
-;; (db:test-get-fail_count resdat)))))))
-;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
-;; (list "test1" "test2" "test3" "test4" "test5"))
-;;
-;;
-;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
-;;
Index: testsmod.scm
==================================================================
--- testsmod.scm
+++ testsmod.scm
@@ -113,10 +113,43 @@
(include "js-path.scm")
(define (init-java-script-lib)
(set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
)
+
+;; pulled from commonmod
+;;
+
+;; return items given config
+;;
+(define (tests:get-items tconfig)
+ (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
+ (itemstable (hash-table-ref/default tconfig "itemstable" #f)))
+ ;; if either items or items table is a proc return it so test running
+ ;; process can know to call items:get-items-from-config
+ ;; if either is a list and none is a proc go ahead and call get-items
+ ;; otherwise return #f - this is not an iterated test
+ (cond
+ ((procedure? items)
+ (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
+ items) ;; calc later
+ ((procedure? itemstable)
+ (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
+ itemstable) ;; calc later
+ ((filter (lambda (x)
+ (let ((val (car x)))
+ (if (procedure? val) val #f)))
+ (append (if (list? items) items '())
+ (if (list? itemstable) itemstable '())))
+ 'have-procedure)
+ ((or (list? items)(list? itemstable)) ;; calc now
+ (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
+ " items: " items " itemstable: " itemstable)
+ (items:get-items-from-config tconfig))
+ (else #f)))) ;; not iterated
+
+
;; Call this one to do all the work and get a standardized list of tests
;; gets paths from configs and finds valid tests
;; returns hash of testname --> fullpath
;;
@@ -411,11 +444,11 @@
;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
(rmt:csv->test-data run-id test-id
dat)
;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start"
;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue.
- (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :)
+ ;; (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :)
;; BB - commentiong out arbitrary 10 second wait (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server.
)))
;; need to update the top test record if PASS or FAIL and this is a subtest
;;;;;; (if (not (equal? item-path ""))
@@ -996,22 +1029,22 @@
;; (map (lambda (testp)
;; (last (string-split testp "/")))
;; tests)))))
(define (tests:get-test-path-from-environment)
- (if (and (getenv "MT_LINKTREE")
- (getenv "MT_TARGET")
- (getenv "MT_RUNNAME")
- (getenv "MT_TEST_NAME")
- (getenv "MT_ITEMPATH"))
- (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
- (getenv "MT_TEST_NAME")
- (if (and (getenv "MT_ITEMPATH")
- (not (string=? "" (getenv "MT_ITEMPATH"))))
- (conc "/" (getenv "MT_ITEMPATH"))
+ (if (and (get-environment-variable "MT_LINKTREE")
+ (get-environment-variable "MT_TARGET")
+ (get-environment-variable "MT_RUNNAME")
+ (get-environment-variable "MT_TEST_NAME")
+ (get-environment-variable "MT_ITEMPATH"))
+ (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
+ (get-environment-variable "MT_TEST_NAME")
+ (if (and (get-environment-variable "MT_ITEMPATH")
+ (not (string=? "" (get-environment-variable "MT_ITEMPATH"))))
+ (conc "/" (get-environment-variable "MT_ITEMPATH"))
""))
#f))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
@@ -1046,13 +1079,13 @@
dat
;; no cached data available
(let* ((treg (or test-registry
(tests:get-all)))
(test-path (or (hash-table-ref/default treg test-name #f)
- (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
+ (let* ((local-tcdir (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
test-name "/" item-path))
(local-tcfg (conc local-tcdir "/testconfig")))
(if (common:file-exists? local-tcfg)
local-tcdir
#f))
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -16,29 +16,33 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format)
-(require-library iup)
+(import format)
+;; (import iup)
(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(import sqlite3 srfi-1
+ chicken.file.posix
+ regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit tree))
-(declare (uses margs))
+(declare (uses mtargs))
+(declare (uses mtver))
(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
-(declare (uses db))
-(declare (uses server))
+(declare (uses dbmod))
+(declare (uses servermod))
;; (declare (uses synchash))
(declare (uses dcommon))
-(include "megatest-version.scm")
+(import mtver)
+;; (include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
;;======================================================================