Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -95,18 +95,18 @@
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
# why were the files mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o listed on this target when MOFILES are there?
# Removed non module .o files (i.e. $(OFILES)
mtest: readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) mofiles/ducttape-lib.o
- csc $(CSCOPTS) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
+ csc megatest.o $(CSCOPTS) $(MOFILES) $(MOIMPFILES) -o mtest
showmtesthash:
@echo $(MTESTHASH)
# removing $(GOFILES)
dboard : dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES)
- csc $(CSCOPTS) dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard
+ csc dashboard.o $(CSCOPTS) $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard
ndboard : newdashboard.scm $(GOFILES)
csc $(CSCOPTS) $(GOFILES) newdashboard.scm -o ndboard
mtut: $(MOFILES) megatest-fossil-hash.scm mtut.scm
@@ -181,10 +181,12 @@
mofiles/tasksmod.o mofiles/odsmod.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o \
mofiles/apimod.o mofiles/ulex.o
mofiles/apimod.o : mofiles/dbmod.o
+mofiles/runsmod.o : mofiles/testsmod.o
+
# Removed from megamod.o dep: mofiles/ftail.o
mofiles/megamod.o : \
mofiles/rmtmod.o \
mofiles/commonmod.o \
mofiles/apimod.o \
Index: api-inc.scm
==================================================================
--- api-inc.scm
+++ api-inc.scm
@@ -132,17 +132,17 @@
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
- (handle-exceptions
- exn
- (let ((call-chain (get-call-chain)))
- (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
+ ;; (handle-exceptions
+ ;; exn
+ ;; (let ((call-chain (get-call-chain)))
+ ;; (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
+ ;; (print-call-chain (current-error-port))
+ ;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(cond
((not (vector? dat)) ;; it is an error to not receive a vector
(vector #f (vector #f "remote must be called with a vector")))
((> *api-process-request-count* 20) ;; 20)
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
@@ -353,11 +353,11 @@
(vector #f res))
(begin
#;(common:telemetry-log (conc "api-out:"(->string cmd))
payload: `((params . ,params)
(ok-res . #f)))
- (vector #t res))))))))
+ (vector #t res))))))) ;; )
;; http-server send-response
;; api:process-request
;; db:*
;;
Index: common-inc.scm
==================================================================
--- common-inc.scm
+++ common-inc.scm
@@ -75,113 +75,10 @@
fullpath))
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
-(define *common:logpro-exit-code->status-sym-alist*
- '( ( 0 . pass )
- ( 1 . fail )
- ( 2 . warn )
- ( 3 . check )
- ( 4 . waived )
- ( 5 . abort )
- ( 6 . skip )))
-
-(define (common:logpro-exit-code->status-sym exit-code)
- (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
-
-(define (common:worse-status-sym ss1 ss2)
- (let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
- (cond
- ((null? status-syms-remaining)
- 'fail)
- ((eq? (car status-syms-remaining) ss1)
- ss1)
- ((eq? (car status-syms-remaining) ss2)
- ss2)
- (else
- (loop (cdr status-syms-remaining))))))
-
-(define (common:steps-can-proceed-given-status-sym status-sym)
- (if (member status-sym '(warn waived pass))
- #t
- #f))
-
-(define (status-sym->string status-sym)
- (case status-sym
- ((pass) "PASS")
- ((fail) "FAIL")
- ((warn) "WARN")
- ((check) "CHECK")
- ((waived) "WAIVED")
- ((abort) "ABORT")
- ((skip) "SKIP")
- (else "FAIL")))
-
-(define (common:logpro-exit-code->test-status exit-code)
- (status-sym->string (common:logpro-exit-code->status-sym exit-code)))
-
-(define (common:clear-caches)
- (set! *target* (make-hash-table))
- (set! *keys* (make-hash-table))
- (set! *keyvals* (make-hash-table))
- (set! *toptest-paths* (make-hash-table))
- (set! *test-paths* (make-hash-table))
- (set! *test-ids* (make-hash-table))
- (set! *test-info* (make-hash-table))
- (set! *run-info-cache* (make-hash-table))
- (set! *env-vars-by-run-id* (make-hash-table))
- (set! *test-id-cache* (make-hash-table)))
-
-;; Generic string database
-(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
-;; Generic path database
-(define *fdb* #f)
-
-(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
-
-;;======================================================================
-;; V E R S I O N
-;;======================================================================
-
-(define (common:get-full-version)
- (conc megatest-version "-" megatest-fossil-hash))
-
-(define (common:version-signature)
- (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-
-;; 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"))
-
-(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)))
-
-;; postive number if megatest version > db version
-;; negative number if megatest version < db version
-(define (common:version-db-delta)
- (- megatest-version (common:get-last-run-version-number)))
-
-(define (common:version-changed?)
- (not (equal? (common:get-last-run-version)
- (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 (common:get-sync-lock-filepath)
- (let* ((tmp-area (common:get-db-tmp-area))
- (lockfile (conc tmp-area "/megatest.db.sync-lock")))
- lockfile))
-
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
(apply db:multi-db-sync
@@ -454,55 +351,10 @@
;;======================================================================
;; U S E F U L S T U F F
;;======================================================================
-;; convert things to an alist or assoc list, #f gets converted to ""
-;;
-(define (common:to-alist dat)
- (cond
- ((list? dat) (map common:to-alist dat))
- ((vector? dat)
- (map common:to-alist (vector->list dat)))
- ((pair? dat)
- (cons (common:to-alist (car dat))
- (common:to-alist (cdr dat))))
- ((hash-table? dat)
- (map common:to-alist (hash-table->alist dat)))
- (else
- (if dat
- dat
- ""))))
-
-(define (common:alist-ref/default key alist default)
- (or (alist-ref key alist) default))
-
-(define (common:low-noise-print waitval . keys)
- (let* ((key (string-intersperse (map conc keys) "-" ))
- (lasttime (hash-table-ref/default *common:denoise* key 0))
- (currtime (current-seconds)))
- (if (> (- currtime lasttime) waitval)
- (begin
- (hash-table-set! *common:denoise* key currtime)
- #t)
- #f)))
-
-(define (common:get-megatest-exe)
- (or (getenv "MT_MEGATEST") "megatest"))
-
-(define (common:read-encoded-string instr)
- (handle-exceptions
- exn
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))
- #f)
- (read (open-input-string (base64:base64-decode instr))))
- (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
-
;; 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
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
@@ -547,45 +399,35 @@
;;======================================================================
;; (define *verbosity* 1)
;; (define *logging* #f)
-(define (get-with-default val default)
- (let ((val (args:get-arg val)))
- (if val val default)))
-
-(define (assoc/default key lst . default)
- (let ((res (assoc key lst)))
- (if res (cadr res)(if (null? default) #f (car default)))))
-
-(define (common:get-testsuite-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")
- (if (string? *toppath* )
- (pathname-file *toppath*)
- #f))) ;; (pathname-file (current-directory)))))
-
-(define common:get-area-name common:get-testsuite-name)
-
-(define (common:get-db-tmp-area . junk)
- (if *db-cache-path*
- *db-cache-path*
- (if *toppath* ;; common:get-create-writeable-dir
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*)
- (exit 1))
- (let ((dbpath (common:get-create-writeable-dir
- (list (conc "/tmp/" (current-user-name)
- "/megatest_localdb/"
- (common:get-testsuite-name) "/"
- (string-translate *toppath* "/" ".")))))) ;; #t))))
- (set! *db-cache-path* dbpath)
- dbpath))
- #f)))
+(define (common:set-last-run-version)
+ (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+
+;; postive number if megatest version > db version
+;; negative number if megatest version < db version
+(define (common:version-db-delta)
+ (- megatest-version (common:get-last-run-version-number)))
+
+(define (common:version-changed?)
+ (not (equal? (common:get-last-run-version)
+ (common:version-signature))))
+
+;; 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"))
+
+(define (common:get-last-run-version-number)
+ (string->number
+ (substring (common:get-last-run-version) 0 6)))
+
+(define (common:api-changed?)
+ (not (equal? (substring (->string megatest-version) 0 4)
+ (substring (conc (common:get-last-run-version)) 0 4))))
+
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
@@ -763,105 +605,10 @@
(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"))
- ;; (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)))
- (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)))
- (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 "%"
- ;; (tags-testpatt
- ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
- ;; tags-testpatt)
- ((and (equal? args-testpatt "%") rtestpatt)
- (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
- rtestpatt)
- (else
- (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
- args-testpatt))))
-
-
-
-(define (common:get-linktree)
- (or (getenv "MT_LINKTREE")
- (if *configdat*
- (configf:lookup *configdat* "setup" "linktree")
- (if *toppath*
- (conc *toppath* "/lt")
- #f))))
-
-(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 ...
- res))
-
-(define (common:get-fields cfgdat)
- (let ((fields (hash-table-ref/default cfgdat "fields" '())))
- (map car fields)))
-
-(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")))
- (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))
- (null? (filter string-null? tlist))))
- #f)))
- (if valid
- (if split
- tlist
- target)
- (if target
- (begin
- (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
- (if exit-if-bad (exit 1))
- #f)
- #f))))
-
-;; 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")))
- #f))
-
;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
(define (common:get-homehost #!key (trynum 5))
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -17,14 +17,14 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit commonmod))
-;; (declare (uses processmod))
+(declare (uses mtargs))
(declare (uses stml2))
(declare (uses mtargs))
-
+
(module commonmod
*
(import scheme chicken data-structures extras)
@@ -34,22 +34,133 @@
regex-case regex hostinfo srfi-4
pkts (prefix dbi dbi:)
stack
md5
message-digest
+ (prefix mtconfigf configf:)
+ stml2
+ ;; (prefix margs args:)
z3 (prefix base64 base64:)
(prefix mtargs args:))
-(import stml2)
(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")
;; no need to export this
(define *verbosity-cache* (make-hash-table))
(define *verbosity* 0)
+
+
+;; GLOBALS
+
+;; CONTEXTS
+#;(defstruct cxt
+ (taskdb #f)
+ (cmutex (make-mutex)))
+;; (define *contexts* (make-hash-table))
+;; (define *context-mutex* (make-mutex))
+
+;; ;; safe method for accessing a context given a toppath
+;; ;;
+;; (define (common:with-cxt toppath proc)
+;; (mutex-lock! *context-mutex*)
+;; (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
+;; (if (not cxt)
+;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
+;; (let ((cxt-mutex (cxt-mutex cxt)))
+;; (mutex-unlock! *context-mutex*)
+;; (mutex-lock! cxt-mutex)
+;; (let ((res (proc cxt)))
+;; (mutex-unlock! cxt-mutex)
+;; res))))
+
+;; A hash table that can be accessed by #{scheme ...} calls in
+;; config files. Allows communicating between confgs
+;;
+(define *user-hash-data* (make-hash-table))
+
+(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
+(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))
+(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
+(define *passnum* 0) ;; when running track calls to run-tests or similar
+;; (define *alt-log-file* #f) ;; used by -log
+(define *common:denoise* (make-hash-table)) ;; for low noise printing
+(define *default-log-port* (current-error-port))
+(define *default-area-tag* "local")
+
+;; DATABASE
+(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
+;; db access
+(define *db-last-access* (current-seconds)) ;; last db access, used in server
+(define *db-write-access* #t)
+;; db sync
+(define *db-last-sync* 0) ;; last time the sync to megatest.db happened
+(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
+(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
+;; task db
+(define *task-db* #f) ;; (vector db path-to-db)
+(define *db-access-allowed* #t) ;; flag to allow access
+(define *db-access-mutex* (make-mutex))
+(define *db-transaction-mutex* (make-mutex))
+(define *db-cache-path* #f)
+(define *db-with-db-mutex* (make-mutex))
+(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
+;; no sync db
+(define *no-sync-db* #f)
+
+;; SERVER
+(define *my-client-signature* #f)
+(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
+(define *runremote* #f) ;; if set up for server communication this will hold
+;; (define *max-cache-size* 0)
+(define *logged-in-clients* (make-hash-table))
+(define *server-id* #f)
+(define *server-info* #f) ;; good candidate for easily convert to non-global
+(define *time-to-exit* #f)
+(define *server-run* #t)
+(define *run-id* #f)
+(define *server-kind-run* (make-hash-table))
+(define *home-host* #f)
+;; (define *total-non-write-delay* 0)
+(define *heartbeat-mutex* (make-mutex))
+(define *api-process-request-count* 0)
+(define *max-api-process-requests* 0)
+(define *server-overloaded* #f)
+
+;; 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
+(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here
+(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
+(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
+
+(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget
+(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
+(define *homehost-mutex* (make-mutex))
+
+;; Miscellaneous
+(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers
+
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
@@ -140,10 +251,105 @@
;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
;; (exec-fn 'db:log-event res))
;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
(apply print "INFO: (" n ") " params) ;; res)
)))) ;; )
+
+;; 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"))
+ ;; (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)))
+ (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)))
+ (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 "%"
+ ;; (tags-testpatt
+ ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
+ ;; tags-testpatt)
+ ((and (equal? args-testpatt "%") rtestpatt)
+ (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
+ rtestpatt)
+ (else
+ (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
+ args-testpatt))))
+
+
+
+(define (common:get-linktree)
+ (or (getenv "MT_LINKTREE")
+ (if *configdat*
+ (configf:lookup *configdat* "setup" "linktree")
+ (if *toppath*
+ (conc *toppath* "/lt")
+ #f))))
+
+(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 ...
+ res))
+
+(define (common:get-fields cfgdat)
+ (let ((fields (hash-table-ref/default cfgdat "fields" '())))
+ (map car fields)))
+
+(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")))
+ (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))
+ (null? (filter string-null? tlist))))
+ #f)))
+ (if valid
+ (if split
+ tlist
+ target)
+ (if target
+ (begin
+ (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
+ (if exit-if-bad (exit 1))
+ #f)
+ #f))))
+
+;; 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")))
+ #f))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
@@ -597,569 +803,177 @@
(length (glob (conc "/proc/" pid "/fd/*")))
(length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
)
)
-
-
-;; GLOBALS
-
-;; CONTEXTS
-#;(defstruct cxt
- (taskdb #f)
- (cmutex (make-mutex)))
-;; (define *contexts* (make-hash-table))
-;; (define *context-mutex* (make-mutex))
-
-;; ;; safe method for accessing a context given a toppath
-;; ;;
-;; (define (common:with-cxt toppath proc)
-;; (mutex-lock! *context-mutex*)
-;; (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
-;; (if (not cxt)
-;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
-;; (let ((cxt-mutex (cxt-mutex cxt)))
-;; (mutex-unlock! *context-mutex*)
-;; (mutex-lock! cxt-mutex)
-;; (let ((res (proc cxt)))
-;; (mutex-unlock! cxt-mutex)
-;; res))))
-
-;; A hash table that can be accessed by #{scheme ...} calls in
-;; config files. Allows communicating between confgs
-;;
-(define *user-hash-data* (make-hash-table))
-
-(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
-(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))
-(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
-(define *passnum* 0) ;; when running track calls to run-tests or similar
-;; (define *alt-log-file* #f) ;; used by -log
-(define *common:denoise* (make-hash-table)) ;; for low noise printing
-(define *default-log-port* (current-error-port))
-(define *default-area-tag* "local")
-
-;; DATABASE
-(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
-;; db access
-(define *db-last-access* (current-seconds)) ;; last db access, used in server
-(define *db-write-access* #t)
-;; db sync
-(define *db-last-sync* 0) ;; last time the sync to megatest.db happened
-(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
-(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
-;; task db
-(define *task-db* #f) ;; (vector db path-to-db)
-(define *db-access-allowed* #t) ;; flag to allow access
-(define *db-access-mutex* (make-mutex))
-(define *db-transaction-mutex* (make-mutex))
-(define *db-cache-path* #f)
-(define *db-with-db-mutex* (make-mutex))
-(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
-;; no sync db
-(define *no-sync-db* #f)
-
-;; SERVER
-(define *my-client-signature* #f)
-(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
-(define *runremote* #f) ;; if set up for server communication this will hold
-;; (define *max-cache-size* 0)
-(define *logged-in-clients* (make-hash-table))
-(define *server-id* #f)
-(define *server-info* #f) ;; good candidate for easily convert to non-global
-(define *time-to-exit* #f)
-(define *server-run* #t)
-(define *run-id* #f)
-(define *server-kind-run* (make-hash-table))
-(define *home-host* #f)
-;; (define *total-non-write-delay* 0)
-(define *heartbeat-mutex* (make-mutex))
-(define *api-process-request-count* 0)
-(define *max-api-process-requests* 0)
-(define *server-overloaded* #f)
-
-;; 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
-(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here
-(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
-(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db
-
-(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget
-(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
-(define *homehost-mutex* (make-mutex))
-
-;; Miscellaneous
-(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-;; (define (common:low-noise-print alldat waitval . keys)
-;; (let* ((key (string-intersperse (map conc keys) "-" ))
-;; (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
-;; (currtime (current-seconds)))
-;; (if (> (- currtime lasttime) waitval)
-;; (begin
-;; (hash-table-set! (alldat-denoise alldat) key currtime)
-;; #t)
-;; #f)))
-;;
-;; (define (common:version-signature alldat)
-;; (conc (alldat-megatest-version alldat)
-;; "-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
-;;
-;; (define (common:get-fields cfgdat)
-;; (let ((fields (hash-table-ref/default cfgdat "fields" '())))
-;; (map car fields)))
-;;
-;; ;;======================================================================
-;; ;; T I M E A N D D A T E
-;; ;;======================================================================
-;;
-;; ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
-;; (define (common:hms-string->seconds tstr)
-;; (let ((parts (string-split-fields "\\w+" tstr))
-;; (time-secs 0)
-;; ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
-;; (trx (regexp "(\\d+)([smhdMyw])")))
-;; (for-each (lambda (part)
-;; (let ((match (string-match trx part)))
-;; (if match
-;; (let ((val (string->number (cadr match)))
-;; (unt (caddr match)))
-;; (if val
-;; (set! time-secs (+ time-secs (* val
-;; (case (string->symbol unt)
-;; ((s) 1)
-;; ((m) 60) ;; minutes
-;; ((h) 3600)
-;; ((d) 86400)
-;; ((w) 604800)
-;; ((M) 2628000) ;; aproximately one month
-;; ((y) 31536000)
-;; (else #f))))))))))
-;; parts)
-;; time-secs))
-;;
-;; (define (seconds->hr-min-sec secs)
-;; (let* ((hrs (quotient secs 3600))
-;; (min (quotient (- secs (* hrs 3600)) 60))
-;; (sec (- secs (* hrs 3600)(* min 60))))
-;; (conc (if (> hrs 0)(conc hrs "hr ") "")
-;; (if (> min 0)(conc min "m ") "")
-;; sec "s")))
-;;
-;; (define (seconds->time-string sec)
-;; (time->string
-;; (seconds->local-time sec) "%H:%M:%S"))
-;;
-;; (define (seconds->work-week/day-time sec)
-;; (time->string
-;; (seconds->local-time sec) "ww%V.%u %H:%M"))
-;;
-;; (define (seconds->work-week/day sec)
-;; (time->string
-;; (seconds->local-time sec) "ww%V.%u"))
-;;
-;; (define (seconds->year-work-week/day sec)
-;; (time->string
-;; (seconds->local-time sec) "%yww%V.%w"))
-;;
-;; (define (seconds->year-work-week/day-time sec)
-;; (time->string
-;; (seconds->local-time sec) "%Yww%V.%w %H:%M"))
-;;
-;; (define (seconds->year-week/day-time sec)
-;; (time->string
-;; (seconds->local-time sec) "%Yw%V.%w %H:%M"))
-;;
-;; (define (seconds->quarter sec)
-;; (case (string->number
-;; (time->string
-;; (seconds->local-time sec)
-;; "%m"))
-;; ((1 2 3) 1)
-;; ((4 5 6) 2)
-;; ((7 8 9) 3)
-;; ((10 11 12) 4)
-;; (else #f)))
-;;
-;; ;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
-;; ;;
-;; (define (common:date-time->seconds datetime)
-;; (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
-;;
-;; ;; given span of seconds tstart to tend
-;; ;; find start time to mark and mark delta
-;; ;;
-;; (define (common:find-start-mark-and-mark-delta tstart tend)
-;; (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
-;; (result #f)
-;; (min 60)
-;; (hr (* 60 60))
-;; (day (* 24 hr))
-;; (yr (* 365 day)) ;; year
-;; (mo (/ yr 12))
-;; (wk (* day 7)))
-;; (for-each
-;; (lambda (max-blks)
-;; (for-each
-;; (lambda (span) ;; 5 2 1
-;; (if (not result)
-;; (for-each
-;; (lambda (timeunit timesym) ;; year month day hr min sec
-;; (if (not result)
-;; (let* ((time-blk (* span timeunit))
-;; (num-blks (quotient deltat time-blk)))
-;; (if (and (> num-blks 4)(< num-blks max-blks))
-;; (let ((first (* (quotient tstart time-blk) time-blk)))
-;; (set! result (list span timeunit time-blk first timesym))
-;; )))))
-;; (list yr mo wk day hr min 1)
-;; '( y mo w d h m s))))
-;; (list 8 6 5 2 1)))
-;; '(5 10 15 20 30 40 50 500))
-;; (if values
-;; (apply values result)
-;; (values 0 day 1 0 'd))))
-;;
-;; ;; given x y lim return the cron expansion
-;; ;;
-;; (define (common:expand-cron-slash x y lim)
-;; (let loop ((curr x)
-;; (res `()))
-;; (if (< curr lim)
-;; (loop (+ curr y) (cons curr res))
-;; (reverse res))))
-;;
-;; ;; expand a complex cron string to a list of cron strings
-;; ;;
-;; ;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c
-;; ;;
-;; ;; NOTE: with flatten a lot of the crud below can be factored down.
-;; ;;
-;; (define (common:cron-expand cron-str)
-;; (if (list? cron-str)
-;; (flatten
-;; (fold (lambda (x res)
-;; (if (list? x)
-;; (let ((newres (map common:cron-expand x)))
-;; (append x newres))
-;; (cons x res)))
-;; '()
-;; cron-str)) ;; (map common:cron-expand cron-str))
-;; (let ((cron-items (string-split cron-str))
-;; (slash-rx (regexp "(\\d+)/(\\d+)"))
-;; (comma-rx (regexp ".*,.*"))
-;; (max-vals '((min . 60)
-;; (hour . 24)
-;; (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
-;; (month . 12)
-;; (dayofweek . 7))))
-;; (if (< (length cron-items) 5) ;; bad spec
-;; cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it
-;; (let loop ((hed (car cron-items))
-;; (tal (cdr cron-items))
-;; (type 'min)
-;; (type-tal '(hour dayofmonth month dayofweek))
-;; (res '()))
-;; (regex-case
-;; hed
-;; (slash-rx ( _ base incr ) (let* ((basen (string->number base))
-;; (incrn (string->number incr))
-;; (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
-;; (new-list-crons (fold (lambda (x myres)
-;; (cons (conc (if (null? res)
-;; ""
-;; (conc (string-intersperse res " ") " "))
-;; x " " (string-intersperse tal " "))
-;; myres))
-;; '() expanded-vals)))
-;; ;; (print "new-list-crons: " new-list-crons)
-;; ;; (fold (lambda (x res)
-;; ;; (if (list? x)
-;; ;; (let ((newres (map common:cron-expand x)))
-;; ;; (append x newres))
-;; ;; (cons x res)))
-;; ;; '()
-;; (flatten (map common:cron-expand new-list-crons))))
-;; ;; (map common:cron-expand (map common:cron-expand new-list-crons))))
-;; (else (if (null? tal)
-;; cron-str
-;; (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
-;;
-;;
-;; ;; given a cron string and the last time event was processed return #t to run or #f to not run
-;; ;;
-;; ;; min hour dayofmonth month dayofweek
-;; ;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7
-;; ;;
-;; ;; #t => yes, run the job
-;; ;; #f => no, do not run the job
-;; ;;
-;; (define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
-;; (let* ((cron-items (map string->number (string-split cron-str)))
-;; (now-seconds (or now-seconds-in (current-seconds)))
-;; (now-time (seconds->local-time now-seconds))
-;; (last-done-time (seconds->local-time last-done))
-;; (all-times (make-hash-table)))
-;; ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
-;; (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
-;; #f
-;; (match-let ((( cmin chour cdayofmonth cmonth cdayofweek)
-;; cron-items)
-;; ;; 0 1 2 3 4 5 6
-;; ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
-;; (vector->list now-time))
-;; ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
-;; (vector->list last-done-time)))
-;; ;; create all possible time slots
-;; ;; remove invalid slots due to (for example) day of week
-;; ;; get the start and end entries for the ref-seconds (current) time
-;; ;; if last-done > ref-seconds => this is an ERROR!
-;; ;; does the last-done time fall in the legit region?
-;; ;; yes => #f do not run again this command
-;; ;; no => #t ok to run the command
-;; (for-each ;; month
-;; (lambda (month)
-;; (for-each ;; dayofmonth
-;; (lambda (dom)
-;; (for-each
-;; (lambda (hr) ;; hour
-;; (for-each
-;; (lambda (minute) ;; minute
-;; (let ((copy-now (apply vector (vector->list now-time))))
-;; (vector-set! copy-now 0 0) ;; force seconds to zero
-;; (vector-set! copy-now 1 minute)
-;; (vector-set! copy-now 2 hr)
-;; (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced
-;; (vector-set! copy-now 4 month)
-;; (let* ((copy-now-secs (local-time->seconds copy-now))
-;; (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector
-;; (if (or (not cdayofweek)
-;; (equal? (vector-ref new-copy 6)
-;; cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
-;; (if (or (not cdayofmonth)
-;; (equal? (vector-ref new-copy 3)
-;; (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
-;; (hash-table-set! all-times copy-now-secs new-copy))))))
-;; (if cmin
-;; `(,cmin) ;; if given cmin, have to use it
-;; (list (- nmin 1) nmin (+ nmin 1))))) ;; minute
-;; (if chour
-;; `(,chour)
-;; (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
-;; (if cdayofmonth
-;; `(,cdayofmonth)
-;; (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
-;; (if cmonth
-;; `(,cmonth)
-;; (list (- nmonth 1) nmonth (+ nmonth 1))))
-;; (let ((before #f)
-;; (is-in #f))
-;; (for-each
-;; (lambda (moment)
-;; (if (and before
-;; (<= before now-seconds)
-;; (>= moment now-seconds))
-;; (begin
-;; ;; (print)
-;; ;; (print "Before: " (time->string (seconds->local-time before)))
-;; ;; (print "Now: " (time->string (seconds->local-time now-seconds)))
-;; ;; (print "After: " (time->string (seconds->local-time moment)))
-;; ;; (print "Last: " (time->string (seconds->local-time last-done)))
-;; (if (< last-done before)
-;; (set! is-in before))
-;; ))
-;; (set! before moment))
-;; (sort (hash-table-keys all-times) <))
-;; is-in)))))
-;;
-;; (define (common:extended-cron cron-str now-seconds-in last-done)
-;; (let ((expanded-cron (common:cron-expand cron-str)))
-;; (if (string? expanded-cron)
-;; (common:cron-event expanded-cron now-seconds-in last-done)
-;; (let loop ((hed (car expanded-cron))
-;; (tal (cdr expanded-cron)))
-;; (if (common:cron-event hed now-seconds-in last-done)
-;; #t
-;; (if (null? tal)
-;; #f
-;; (loop (car tal)(cdr tal))))))))
-;;
-;; ;;======================================================================
-;; ;; C O L O R S
-;; ;;======================================================================
-;;
-;; (define (common:name->iup-color name)
-;; (case (string->symbol (string-downcase name))
-;; ((red) "223 33 49")
-;; ((grey) "192 192 192")
-;; ((orange) "255 172 13")
-;; ((purple) "This is unfinished ...")))
-;;
-;; ;; (define (common:get-color-for-state-status state status)
-;; ;; (case (string->symbol state)
-;; ;; ((COMPLETED)
-;; ;; (case (string->symbol status)
-;; ;; ((PASS) "70 249 73")
-;; ;; ((WARN WAIVED) "255 172 13")
-;; ;; ((SKIP) "230 230 0")
-;; ;; (else "223 33 49")))
-;; ;; ((LAUNCHED) "101 123 142")
-;; ;; ((CHECK) "255 100 50")
-;; ;; ((REMOTEHOSTSTART) "50 130 195")
-;; ;; ((RUNNING) "9 131 232")
-;; ;; ((KILLREQ) "39 82 206")
-;; ;; ((KILLED) "234 101 17")
-;; ;; ((NOT_STARTED) "240 240 240")
-;; ;; (else "192 192 192")))
-;;
-;; (define (common:iup-color->rgb-hex instr)
-;; (string-intersperse
-;; (map (lambda (x)
-;; (number->string x 16))
-;; (map string->number
-;; (string-split instr)))
-;; "/"))
-;;
-;; ;; 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
-;; ;;
-;; (define (common:simple-file-lock fname #!key (expire-time 300))
-;; (if (file-exists? fname)
-;; (if (> (- (current-seconds)(file-modification-time fname)) expire-time)
-;; (begin
-;; (handle-exceptions exn #f (delete-file* fname))
-;; (common:simple-file-lock fname expire-time: expire-time))
-;; #f)
-;; (let ((key-string (conc (get-host-name) "-" (current-process-id))))
-;; (with-output-to-file fname
-;; (lambda ()
-;; (print key-string)))
-;; (thread-sleep! 0.25)
-;; (if (file-exists? fname)
-;; (handle-exceptions exn
-;; #f
-;; (with-input-from-file fname
-;; (lambda ()
-;; (equal? key-string (read-line)))))
-;; #f))))
-;;
-;; (define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
-;; (let ((end-time (+ expire-time (current-seconds))))
-;; (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
-;; (if got-lock
-;; #t
-;; (if (> end-time (current-seconds))
-;; (begin
-;; (thread-sleep! 3)
-;; (loop (common:simple-file-lock fname expire-time: expire-time)))
-;; #f)))))
-;;
-;; (define (common:simple-file-release-lock fname)
-;; (handle-exceptions
-;; exn
-;; #f ;; I don't really care why this failed (at least for now)
-;; (delete-file* fname)))
-;;
-;; ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
-;; ;;
-;; (define (common:lazy-modification-time fpath)
-;; (handle-exceptions
-;; exn
-;; 0
-;; (file-modification-time fpath)))
-;;
-;; ;; find timestamp of newest file associated with a sqlite db file
-;; (define (common:lazy-sqlite-db-modification-time fpath)
-;; (let* ((glob-list (handle-exceptions
-;; exn
-;; `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
-;; (glob (conc fpath "*"))))
-;; (file-list (if (eq? 0 (length glob-list))
-;; '("/no/such/file")
-;; glob-list)))
-;; (apply max
-;; (map
-;; common:lazy-modification-time
-;; file-list))))
-;;
-;;
-;; ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
-;; ;; arguments - thunk, message
-;; (define (common:fail-safe thunk warning-message-on-exception)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception)
-;; (debug:print-info 0 *default-log-port*
-;; (string-substitute "\n?Error:" "nonfatal condition:"
-;; (with-output-to-string
-;; (lambda ()
-;; (print-error-message exn) ))))
-;; (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...")
-;; #f)
-;; (thunk)))
-;;
-;; (define getenv get-environment-variable)
-;; (define (safe-setenv key val)
-;; (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables.
-;; (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
-;; (if (and (string? val)
-;; (string? key))
-;; (handle-exceptions
-;; exn
-;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
-;; (setenv key val))
-;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
-;;
-;; (define home (getenv "HOME"))
-;; (define user (getenv "USER"))
-;;
-;;
-;; ;; returns list of fd count, socket count
-;; (define (get-file-descriptor-count #!key (pid (current-process-id )))
-;; (list
-;; (length (glob (conc "/proc/" pid "/fd/*")))
-;; (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
-;; )
-;; )
-;;
+(define *common:logpro-exit-code->status-sym-alist*
+ '( ( 0 . pass )
+ ( 1 . fail )
+ ( 2 . warn )
+ ( 3 . check )
+ ( 4 . waived )
+ ( 5 . abort )
+ ( 6 . skip )))
+
+(define (common:logpro-exit-code->status-sym exit-code)
+ (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
+
+(define (common:worse-status-sym ss1 ss2)
+ (let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
+ (cond
+ ((null? status-syms-remaining)
+ 'fail)
+ ((eq? (car status-syms-remaining) ss1)
+ ss1)
+ ((eq? (car status-syms-remaining) ss2)
+ ss2)
+ (else
+ (loop (cdr status-syms-remaining))))))
+
+(define (common:steps-can-proceed-given-status-sym status-sym)
+ (if (member status-sym '(warn waived pass))
+ #t
+ #f))
+
+(define (status-sym->string status-sym)
+ (case status-sym
+ ((pass) "PASS")
+ ((fail) "FAIL")
+ ((warn) "WARN")
+ ((check) "CHECK")
+ ((waived) "WAIVED")
+ ((abort) "ABORT")
+ ((skip) "SKIP")
+ (else "FAIL")))
+
+(define (common:logpro-exit-code->test-status exit-code)
+ (status-sym->string (common:logpro-exit-code->status-sym exit-code)))
+
+(define (common:clear-caches)
+ (set! *target* (make-hash-table))
+ (set! *keys* (make-hash-table))
+ (set! *keyvals* (make-hash-table))
+ (set! *toptest-paths* (make-hash-table))
+ (set! *test-paths* (make-hash-table))
+ (set! *test-ids* (make-hash-table))
+ (set! *test-info* (make-hash-table))
+ (set! *run-info-cache* (make-hash-table))
+ (set! *env-vars-by-run-id* (make-hash-table))
+ (set! *test-id-cache* (make-hash-table)))
+
+;; Generic string database
+(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
+;; Generic path database
+(define *fdb* #f)
+
+(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
+
+;;======================================================================
+;; V E R S I O N
+;;======================================================================
+
+(define (common:get-full-version)
+ (conc megatest-version "-" megatest-fossil-hash))
+
+(define (common:version-signature)
+ (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
+
+
+(define (common:get-sync-lock-filepath)
+ (let* ((tmp-area (common:get-db-tmp-area))
+ (lockfile (conc tmp-area "/megatest.db.sync-lock")))
+ lockfile))
+
+;;======================================================================
+;; U S E F U L S T U F F
+;;======================================================================
+
+;; convert things to an alist or assoc list, #f gets converted to ""
+;;
+(define (common:to-alist dat)
+ (cond
+ ((list? dat) (map common:to-alist dat))
+ ((vector? dat)
+ (map common:to-alist (vector->list dat)))
+ ((pair? dat)
+ (cons (common:to-alist (car dat))
+ (common:to-alist (cdr dat))))
+ ((hash-table? dat)
+ (map common:to-alist (hash-table->alist dat)))
+ (else
+ (if dat
+ dat
+ ""))))
+
+(define (common:alist-ref/default key alist default)
+ (or (alist-ref key alist) default))
+
+(define (common:low-noise-print waitval . keys)
+ (let* ((key (string-intersperse (map conc keys) "-" ))
+ (lasttime (hash-table-ref/default *common:denoise* key 0))
+ (currtime (current-seconds)))
+ (if (> (- currtime lasttime) waitval)
+ (begin
+ (hash-table-set! *common:denoise* key currtime)
+ #t)
+ #f)))
+
+(define (common:get-megatest-exe)
+ (or (getenv "MT_MEGATEST") "megatest"))
+
+(define (common:read-encoded-string instr)
+ (handle-exceptions
+ exn
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port))
+ #f)
+ (read (open-input-string (base64:base64-decode instr))))
+ (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
+
+;;======================================================================
+;; Configf extentions
+;;======================================================================
+
+(define (get-with-default val default)
+ (let ((val (args:get-arg val)))
+ (if val val default)))
+
+(define (assoc/default key lst . default)
+ (let ((res (assoc key lst)))
+ (if res (cadr res)(if (null? default) #f (car default)))))
+
+(define (common:get-testsuite-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")
+ (if (string? *toppath* )
+ (pathname-file *toppath*)
+ #f))) ;; (pathname-file (current-directory)))))
+
+(define common:get-area-name common:get-testsuite-name)
+
+(define (common:get-db-tmp-area . junk)
+ (if *db-cache-path*
+ *db-cache-path*
+ (if *toppath* ;; common:get-create-writeable-dir
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*)
+ (exit 1))
+ (let ((dbpath (common:get-create-writeable-dir
+ (list (conc "/tmp/" (current-user-name)
+ "/megatest_localdb/"
+ (common:get-testsuite-name) "/"
+ (string-translate *toppath* "/" ".")))))) ;; #t))))
+ (set! *db-cache-path* dbpath)
+ dbpath))
+ #f)))
+
;; pulled from common_records.scm
;; globals - modules that include this need these here
(define *logging* #f)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -30,69 +30,63 @@
sparse-vectors srfi-18
#;(prefix mtconfigf configf:)
)
(import (prefix sqlite3 sqlite3:))
-;; (declare (uses common))
-;; (declare (uses margs))
-;; (declare (uses keys))
-;; (declare (uses items))
-;; (declare (uses db))
-;; (declare (uses process))
-;; (declare (uses launch))
-;; (declare (uses runs))
-;; (declare (uses dashboard-tests))
-;; (declare (uses dashboard-guimonitor))
-;; (declare (uses tree))
-;; (declare (uses dcommon))
-;; (declare (uses dashboard-context-menu))
-;; (declare (uses vg))
-;; (declare (uses subrun))
-;; ;; (declare (uses dashboard-main))
-;; (declare (uses megatest-version))
-;; (declare (uses mt))
+(declare (uses mtargs))
+(import (prefix mtargs args:))
+
+(declare (uses ducttape-lib))
+(import ducttape-lib)
+
+(declare (uses mtconfigf))
+(import (prefix mtconfigf configf:))
+
+;; invoke the imports - ORDER IS IMPORTANT!
+(declare (uses mtargs.import))
+(declare (uses ducttape-lib.import))
+(declare (uses mtconfigf.import))
(declare (uses megamod))
(import megamod)
(declare (uses commonmod))
(import commonmod)
+
(declare (uses rmtmod))
(import rmtmod)
+
(declare (uses runsmod))
(import runsmod)
+
(declare (uses dbmod))
(import dbmod)
+
+(declare (uses testsmod))
+(import testsmod)
(declare (uses dcommonmod))
(import dcommonmod)
-(declare (uses mtargs))
-(import (prefix mtargs args:))
-(declare (uses ducttape-lib))
-(import ducttape-lib)
-(declare (uses mtconfigf))
-(import (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "vg_records.scm")
-;; invoke the imports
+;; invoke the imports - ORDER IS IMPORTANT!
(declare (uses commonmod.import))
+(declare (uses testsmod.import))
(declare (uses rmtmod.import))
(declare (uses runsmod.import))
(declare (uses megamod.import))
(declare (uses dcommonmod.import))
-(declare (uses mtargs.import))
-(declare (uses ducttape-lib.import))
-(declare (uses mtconfigf.import))
-(configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
-(configf:add-eval-string "(import megamod commonmod (prefix mtargs args:))")
+;; (mtconfigf#set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
+;; (configf:add-eval-string "(import megamod commonmod (prefix mtargs args:))")
+(mtconfigf#add-eval-string "(import megamod)(import commonmod)(prefix mtargs args:)")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
Index: db-inc.scm
==================================================================
--- db-inc.scm
+++ db-inc.scm
@@ -2087,31 +2087,10 @@
(set! res val))
db
(conc "SELECT " key " FROM runs WHERE id=?;")
run-id)
res))))
-
-;; keys list to key1,key2,key3 ...
-(define (runs:get-std-run-fields keys remfields)
- (let* ((header (append keys remfields))
- (keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ","))))
- (list keystr header)))
-
-;; make a query (fieldname like 'patt1' OR fieldname
-(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
- (let ((patts (if (string? pattstr)
- (string-split pattstr ",")
- '("%"))))
- (string-intersperse (map (lambda (patt)
- (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
- (conc fieldname " " wildtype " '" patt "'")))
- (if (null? patts)
- '("")
- patts))
- comparator)))
-
;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user contour-in)
@@ -2480,11 +2459,11 @@
(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update sort-order ) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
(keystr (car tmp))
(header (cadr tmp))
(key-patt "")
- (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
+ (runwildtype (if (substring-index "%" (or runnamepatt "%")) "like" "glob"))
(qry-str #f)
(keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
(for-each (lambda (keyval)
(let* ((key (car keyval))
(patt (cadr keyval))
@@ -4325,74 +4304,10 @@
res))))
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
-
-;; A routine to map itempaths using a itemmap
-;; patha and pathb must be strings or this will fail
-;;
-;; path-b is waiting on path-a
-;;
-(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
- (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
- (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
- (if itemmap
- (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
- (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
- (equal? path-a path-b-mapped))
- (equal? path-b path-a))))
-
-;; A routine to convert test/itempath using a itemmap
-;; NOTE: to process only an itempath (i.e. no prepended testname)
-;; just call db:multi-pattern-apply
-;;
-(define (db:convert-test-itempath path-in itemmap)
- (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
- (let* ((path-parts (string-split path-in "/"))
- (test-name (if (null? path-parts) "" (car path-parts)))
- (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
- (conc test-name "/"
- (db:multi-pattern-apply item-path itemmap))))
-
-;; patterns are:
-;; "rx1" "replacement1"\n
-;; "rx2" "replacement2"
-;; etc.
-;;
-(define (db:multi-pattern-apply item-path itemmap)
- (let ((all-patts (string-split itemmap "\n")))
- (if (null? all-patts)
- item-path
- (let loop ((hed (car all-patts))
- (tal (cdr all-patts))
- (res item-path))
- (let* ((parts (string-split hed))
- (patt (car parts))
-
- (repl (if (> (length parts) 1)(cadr parts) ""))
-
- (newr (if (and patt repl)
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port*
- "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
- res)
- (string-substitute patt repl res))
-
-
- )
- (begin
- (debug:print 0 *default-log-port*
- "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
- res))))
- (if (null? tal)
- newr
- (loop (car tal)(cdr tal) newr)))))))
-
;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met
Index: dcommonmod.scm
==================================================================
--- dcommonmod.scm
+++ dcommonmod.scm
@@ -18,10 +18,11 @@
;;======================================================================
(declare (unit dcommonmod))
(declare (uses commonmod))
+(declare (uses testsmod))
(declare (uses megamod))
(declare (uses mtargs))
(module dcommonmod
*
@@ -81,10 +82,11 @@
)
(use (prefix mtconfigf configf:))
(import commonmod)
+(import testsmod)
(import megamod)
(import canvas-draw)
(import canvas-draw-iup)
(use (prefix iup iup:))
(import (prefix mtargs args:))
Index: keys-inc.scm
==================================================================
--- keys-inc.scm
+++ keys-inc.scm
@@ -15,62 +15,5 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-;;======================================================================
-;; Run keys, these are used to hierarchially organise tests and run areas
-;;======================================================================
-
-(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
- (string-intersperse keys ","))
-
-(define (args:usage . a) #f)
-
-;;======================================================================
-;; key <=> target routines
-;;======================================================================
-
-;; This invalidates using "/" in item names. Every key will be
-;; available via args:get-arg as :keyfield. Since this only needs to
-;; be called once let's use it to set the environment vars
-;;
-;; The setting of :keyfield in args should be turned off ASAP
-;;
-(define (keys:target-set-args keys target ht)
- (if target
- (let ((vals (string-split target "/")))
- (if (eq? (length vals)(length keys))
- (for-each (lambda (key val)
- (setenv key val)
- (if ht (hash-table-set! ht (conc ":" key) val)))
- keys
- vals)
- (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
- vals)
- (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
-
-;; given the keys (a list of vectors or a list of keys) and a target return a keyval list
-;; keyval list ( (key1 val1) (key2 val2) ...)
-(define (keys:target->keyval keys target)
- (let* ((targlist (string-split target "/"))
- (numkeys (length keys))
- (numtarg (length targlist))
- (targtweaked (if (> numkeys numtarg)
- (append targlist (make-list (- numkeys numtarg) ""))
- targlist)))
- (map (lambda (key targ)
- (list key targ))
- keys targtweaked)))
-
-;;======================================================================
-;; config file related routines
-;;======================================================================
-
-(define keys:config-get-fields common:get-fields)
-(define (keys:make-key/field-string confdat)
- (let ((fields (configf:get-section confdat "fields")))
- (string-join
- (map (lambda (field)(conc (car field) " " (cadr field)))
- fields)
- ",")))
-
Index: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -39,11 +39,11 @@
;; (declare (uses runconfigmod))
(declare (uses runsmod))
;; (declare (uses servermod))
;; (declare (uses subrunmod))
;; (declare (uses tasksmod))
-;; (declare (uses testsmod))
+(declare (uses testsmod))
;; (declare (uses vgmod))
(declare (uses pkts))
(declare (uses mtargs))
(declare (uses mtconfigf))
(declare (uses ducttape-lib))
@@ -127,11 +127,11 @@
;; (import runconfigmod)
(import runsmod)
;; (import servermod)
;; (import subrunmod)
;; (import tasksmod)
-;; (import testsmod)
+(import testsmod)
;; (import vgmod)
(import pkts)
(import (prefix mtargs args:))
(import ducttape-lib)
@@ -176,11 +176,11 @@
(include "common-inc.scm") ;; L5
(include "db-inc.scm") ;; L4
(include "env-inc.scm")
(include "http-transport-inc.scm")
(include "items-inc.scm")
-(include "keys-inc.scm")
+;; (include "keys-inc.scm")
(include "launch-inc.scm") ;; L1
;; (include "margs-inc.scm")
(include "mt-inc.scm")
(include "ods-inc.scm") ;; L1
(include "pgdb-inc.scm")
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -30,46 +30,42 @@
;;
(use sparse-vectors)
(require-library mutils)
-(declare (uses commonmod))
-(import commonmod)
-(declare (uses rmtmod))
-(import rmtmod)
-(declare (uses dbmod))
-(import dbmod)
-(declare (uses runsmod))
-(import runsmod)
-(declare (uses megamod))
-(import megamod)
(declare (uses mtargs))
(import (prefix mtargs args:))
(declare (uses mtconfigf))
(import (prefix mtconfigf configf:))
(declare (uses ducttape-lib))
(import ducttape-lib)
-
;; invoke the imports
-(declare (uses commonmod.import))
-(declare (uses rmtmod.import))
-(declare (uses runsmod.import))
-(declare (uses megamod.import))
(declare (uses mtargs.import))
(declare (uses mtconfigf.import))
(declare (uses ducttape-lib.import))
+(declare (uses commonmod))
+(import commonmod)
+(declare (uses rmtmod))
+(import rmtmod)
+(declare (uses dbmod))
+(import dbmod)
+(declare (uses runsmod))
+(import runsmod)
+(declare (uses testsmod))
+(import testsmod)
+(declare (uses megamod))
+(import megamod)
+
+;; invoke the imports
+(declare (uses commonmod.import))
+(declare (uses testsmod.import))
+(declare (uses rmtmod.import))
+(declare (uses runsmod.import))
+(declare (uses megamod.import))
(configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
-;; (declare (uses tdb))
-;; (declare (uses mt))
-;; (declare (uses api))
-;; (declare (uses tasks)) ;; only used for debugging.
-;; (declare (uses env))
-;; (declare (uses diff-report))
-;; (declare (uses ftail))
-;; (import ftail)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(define *default-log-port* (current-error-port))
(include "common_records.scm")
@@ -77,11 +73,11 @@
(include "db_records.scm")
(include "run_records.scm")
;; (include "megatest-fossil-hash.scm") ;; included in megamod
(define getenv get-environment-variable)
-(configf:add-eval-string "(import megamod)(import commonmod)")
+(configf:add-eval-string "(import megamod commonmod (prefix mtconfigf configf:)(prefix mtargs args:))")
(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
;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
Index: rmt-inc.scm
==================================================================
--- rmt-inc.scm
+++ rmt-inc.scm
@@ -71,138 +71,142 @@
#f))))
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
-
- #;(common:telemetry-log (conc "rmt:"(->string cmd))
- payload: `((rid . ,rid)
- (params . ,params)))
-
- ;; do all the prep locked under the rmt-mutex
- (mutex-lock! *rmt-mutex*)
-
- ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
- ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
- ;; 3. do the query, if on homehost use local access
- ;;
- (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
- (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
- (runremote (or area-dat
- *runremote*))
- (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
-
- ;; ensure we have a record for our connection for given area
- (if (not runremote) ;; can remove this one. should never get here.
- (begin
- (set! *runremote* (make-remote))
- (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
-
- ;; ensure we have a homehost record
- (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
- (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
- (remote-hh-dat-set! runremote (common:get-homehost)))
-
- ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
- (cond
- ;; give up if more than 15 attempts
- ((> attemptnum 15)
- (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
- (exit 1))
-
- ;; readonly mode, read request- handle it - case 2
- ((and readonly-mode
- (member cmd api:read-only-queries))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
- (rmt:open-qry-close-locally cmd 0 params)
- )
-
- ;; readonly mode, write request. Do nothing, return #f
- (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
-
- ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
- ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
- ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
- ;;
- ;; reset the connection if it has been unused too long
- ((and runremote
- (remote-conndat runremote)
- (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
- (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
- (remote-server-timeout runremote))))
- (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
- (http-transport:close-connections area-dat: runremote)
- (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
- (mutex-unlock! *rmt-mutex*)
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;; on homehost and this is a read
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (member cmd api:read-only-queries)) ;; this is a read
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;; on homehost and this is a write, we already have a server, but server has died
- ((and (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote) ;; have a server
- (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
- (set! *runremote* (make-remote))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;; on homehost and this is a write, we already have a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote)) ;; have a server
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;; on homehost, no server contact made and this is a write, passively start a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; have homehost
- (not (remote-server-url runremote)) ;; no connection yet
- (not (member cmd api:read-only-queries))) ;; not a read-only query
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
- (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
- (if server-url
- (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
- (if (common:force-server?)
- (server:start-and-wait *toppath*)
- (server:kind-run *toppath*))))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
- (not (remote-conndat runremote)))
- (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
- (not (remote-conndat runremote)))) ;; and no connection
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
- (mutex-unlock! *rmt-mutex*)
- (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
- (server:start-and-wait *toppath*))
- (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
- (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
-
- ;; all set up if get this far, dispatch the query
- ((and (not (remote-force-server runremote))
- (cdr (remote-hh-dat runremote))) ;; we are on homehost
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
- (rmt:open-qry-close-locally cmd (if rid rid 0) params))
-
- ;; not on homehost, do server query
- (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
+ (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
+;; ;; #;(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
+;; ;;
+;; ;; #;(common:telemetry-log (conc "rmt:"(->string cmd))
+;; ;; payload: `((rid . ,rid)
+;; ;; (params . ,params)))
+;; ;;
+;; ;; do all the prep locked under the rmt-mutex
+;; (mutex-lock! *rmt-mutex*)
+;;
+;; ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
+;; ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
+;; ;; 3. do the query, if on homehost use local access
+;; ;;
+;; (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
+;; (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
+;; (runremote (or area-dat
+;; *runremote*))
+;; (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
+;;
+;; ;; ensure we have a record for our connection for given area
+;; (if (not runremote) ;; can remove this one. should never get here.
+;; (begin
+;; (set! *runremote* (make-remote))
+;; (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
+;;
+;; ;; ensure we have a homehost record
+;; (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
+;; (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
+;; (remote-hh-dat-set! runremote (common:get-homehost)))
+;;
+;; ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
+;; (cond
+;; ;; give up if more than 15 attempts
+;; ((> attemptnum 15)
+;; (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
+;; (exit 1))
+;;
+;; ;; readonly mode, read request- handle it - case 2
+;; ((and readonly-mode
+;; (member cmd api:read-only-queries))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
+;; (rmt:open-qry-close-locally cmd 0 params)
+;; )
+;;
+;; ;; readonly mode, write request. Do nothing, return #f
+;; (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
+;;
+;; ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
+;; ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
+;; ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
+;; ;;
+;; ;; reset the connection if it has been unused too long
+;; ((and runremote
+;; (remote-conndat runremote)
+;; (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
+;; (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
+;; (remote-server-timeout runremote))))
+;; (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
+;; (http-transport:close-connections area-dat: runremote)
+;; (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
+;; (mutex-unlock! *rmt-mutex*)
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;;
+;; ;; on homehost and this is a read
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; on homehost
+;; (member cmd api:read-only-queries)) ;; this is a read
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ;; on homehost and this is a write, we already have a server, but server has died
+;; ((and (cdr (remote-hh-dat runremote)) ;; on homehost
+;; (not (member cmd api:read-only-queries)) ;; this is a write
+;; (remote-server-url runremote) ;; have a server
+;; (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
+;; (set! *runremote* (make-remote))
+;; (remote-force-server-set! runremote (common:force-server?))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum))
+;;
+;; ;; on homehost and this is a write, we already have a server
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; on homehost
+;; (not (member cmd api:read-only-queries)) ;; this is a write
+;; (remote-server-url runremote)) ;; have a server
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ;; on homehost, no server contact made and this is a write, passively start a server
+;; ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+;; (cdr (remote-hh-dat runremote)) ;; have homehost
+;; (not (remote-server-url runremote)) ;; no connection yet
+;; (not (member cmd api:read-only-queries))) ;; not a read-only query
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
+;; (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
+;; (if server-url
+;; (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
+;; (if (common:force-server?)
+;; (server:start-and-wait *toppath*)
+;; (server:kind-run *toppath*))))
+;; (remote-force-server-set! runremote (common:force-server?))
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
+;; (rmt:open-qry-close-locally cmd 0 params))
+;;
+;; ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
+;; (not (remote-conndat runremote)))
+;; (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
+;; (not (remote-conndat runremote)))) ;; and no connection
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
+;; (mutex-unlock! *rmt-mutex*)
+;; (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
+;; (server:start-and-wait *toppath*))
+;; (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
+;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
+;;
+;; ;; all set up if get this far, dispatch the query
+;; ((and (not (remote-force-server runremote))
+;; (cdr (remote-hh-dat runremote))) ;; we are on homehost
+;; (mutex-unlock! *rmt-mutex*)
+;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
+;; (rmt:open-qry-close-locally cmd (if rid rid 0) params))
+;;
+;; ;; not on homehost, do server query
+;; (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
;; bunch of small functions factored out of send-receive to make debug easier
;;
(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
Index: runs-inc.scm
==================================================================
--- runs-inc.scm
+++ runs-inc.scm
@@ -270,14 +270,10 @@
(debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
(debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
(system (conc run-post-hook " >> " actual-logf " 2>&1"))
(debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
-;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
-(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
- (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))
-
;;======================================================================
;; runs:run-tests is called from megatest.scm and itself
;;======================================================================
;;
;; test-names: Comma separated patterns same as test-patts but used in selection
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -18,17 +18,19 @@
;;======================================================================
(declare (unit runsmod))
(declare (uses commonmod))
+(declare (uses testsmod))
(module runsmod
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import commonmod)
+(import testsmod)
;; (use (prefix ulex ulex:))
;; (include "common_records.scm")
(defstruct runs:dat
reglen regfull
@@ -89,7 +91,11 @@
(if (> (- currtime lasttime) waitval)
(begin
(hash-table-set! *runs:denoise* key currtime)
#t)
#f)))
+
+;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
+(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
+ (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))
)
Index: tests-inc.scm
==================================================================
--- tests-inc.scm
+++ tests-inc.scm
@@ -20,105 +20,10 @@
;;======================================================================
;; Tests
;;======================================================================
-(define *java-script-lib* #f)
-
-(define (init-java-script-lib)
- (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
- )
-
-;; 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
-;;
-(define (tests:get-all)
- (let* ((test-search-path (tests:get-tests-search-path *configdat*)))
- (tests:get-valid-tests (make-hash-table) test-search-path)))
-
-(define (tests:get-tests-search-path cfgdat)
- (let ((paths (let ((section (if cfgdat
- (configf:get-section cfgdat "tests-paths")
- #f)))
- (if section
- (map cadr section)
- '()))))
- (filter (lambda (d)
- (if (directory-exists? d)
- d
- (begin
- (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
- (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
- #f)))
- (append paths (list (conc *toppath* "/tests"))))))
-
-(define (tests:get-valid-tests test-registry tests-paths)
- (if (null? tests-paths)
- test-registry
- (let loop ((hed (car tests-paths))
- (tal (cdr tests-paths)))
- (if (common:file-exists? hed)
- (for-each (lambda (test-path)
- (let* ((tname (last (string-split test-path "/")))
- (tconfig (conc test-path "/testconfig")))
- (if (and (not (hash-table-ref/default test-registry tname #f))
- (common:file-exists? tconfig))
- (hash-table-set! test-registry tname test-path))))
- (glob (conc hed "/*"))))
- (if (null? tal)
- test-registry
- (loop (car tal)(cdr tal))))))
-
-(define (tests:filter-test-names-not-matched test-names test-patts)
- (delete-duplicates
- (filter (lambda (testname)
- (not (tests:match test-patts testname #f)))
- test-names)))
-
-
-(define (tests:filter-test-names test-names test-patts)
- (delete-duplicates
- (filter (lambda (testname)
- (tests:match test-patts testname #f))
- test-names)))
-
-;; itemmap is a list of testname patterns to maps
-;; test1 .*/bar/(\d+) foo/\1
-;; % foo/([^/]+) \1/bar
-;;
-;; # NOTE: the line with the single % could be the result of
-;; # itemmap entry in requirements (legacy). The itemmap
-;; # requirements entry is deprecated
-;;
-(define (tests:get-itemmaps tconfig)
- (let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap"))
- (itemmap-table (configf:get-section tconfig "itemmap")))
- (append (if base-itemmap
- (list (list "%" base-itemmap))
- '())
- (if itemmap-table
- itemmap-table
- '()))))
-
-;; given a list of itemmaps (testname . map), return the first match
-;;
-(define (tests:lookup-itemmap itemmaps testname)
- (let ((best-matches (filter (lambda (itemmap)
- (tests:match (car itemmap) testname #f))
- itemmaps)))
- (if (null? best-matches)
- #f
- (let ((res (car best-matches)))
- ;; (debug:print 0 *default-log-port* "res=" res)
- (cond
- ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
- ((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)))
@@ -195,135 +100,10 @@
(debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
#f)))
newwaitors)
config)))))
-;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
-;;
-;; genlib/testconfig sim/testconfig
-;; genlib/sch sim/sch/cell1
-;;
-;; [requirements] [requirements]
-;; mode itemwait
-;; # trim off the cell to determine what to run for genlib
-;; itemmap /.*
-;;
-;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
-;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '())
-;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/"
-;; expected -> "normal-first,normal-second/2,normal-second/"
-;; testpatt = normal-second/2
-;; waiting-test = normal-second
-;; waiton-test = normal-first
-;; itemmaps = ()
-
-(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton)
- (cond
- (itemized-waiton
- (let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test))
- (patts (string-split test-patt ","))
- (waiting-test-len (+ (string-length waiting-test) 1))
- (patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test
- (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x))
- (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
- ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
- ;; (print "in map, x=" x ", newpatt=" newpatt)
- newpatt))
- (filter (lambda (x)
- (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
- patts)))
- (extended-test-patt (append patts (if (null? patts-waiton)
- (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
- patts-waiton)))
- (extended-test-patt-with-toplevels
- (fold (lambda (testpatt-item accum )
- (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item)))
- (cons testpatt-item
- (if my-match
- (cons
- (conc (cadr my-match) "/")
- accum)
- accum))))
- '()
- extended-test-patt)))
- (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ",")))
- (else ;; not waiting on items, waiting on entire waiton test.
- (let* ((patts (string-split test-patt ","))
- (new-patts (if (member waiton-test patts)
- patts
- (cons waiton-test patts))))
- (string-intersperse (delete-duplicates new-patts) ",")))))
-
-
-
-;; tests:glob-like-match
-(define (tests:glob-like-match patt str)
- (let ((like (substring-index "%" patt)))
- (let* ((notpatt (equal? (substring-index "~" patt) 0))
- (newpatt (if notpatt (substring patt 1) patt))
- (finpatt (if like
- (string-substitute (regexp "%") ".*" newpatt #f)
- (string-substitute (regexp "\\*") ".*" newpatt #f)))
- (res #f))
- ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
- (set! res (string-match (regexp finpatt (if like #t #f)) str))
- (if notpatt (not res) res))))
-
-;; if itempath is #f then look only at the testname part
-;;
-(define (tests:match patterns testname itempath #!key (required '()))
- (if (string? patterns)
- (let ((patts (append (string-split patterns ",") required)))
- (if (null? patts) ;;; no pattern(s) means no match
- #f
- (let loop ((patt (car patts))
- (tal (cdr patts)))
- ;; (print "loop: patt: " patt ", tal " tal)
- (if (string=? patt "")
- #f ;; nothing ever matches empty string - policy
- (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
- (test-patt (cadr patt-parts))
- (item-patt (cadddr patt-parts)))
- ;; special case: test vs. test/
- ;; test => "test" "%"
- ;; test/ => "test" ""
- (if (and (not (substring-index "/" patt)) ;; no slash in the original
- (or (not item-patt)
- (equal? item-patt ""))) ;; should always be true that item-patt is ""
- (set! item-patt "%"))
- ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
- (if (and (tests:glob-like-match test-patt testname)
- (or (not itempath)
- (tests:glob-like-match (if item-patt item-patt "") itempath)))
- #t
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))))))
-
-;; if itempath is #f then look only at the testname part
-;;
-(define (tests:match->sqlqry patterns)
- (if (string? patterns)
- (let ((patts (string-split patterns ",")))
- (if (null? patts) ;;; no pattern(s) means no match, we will do no query
- #f
- (let loop ((patt (car patts))
- (tal (cdr patts))
- (res '()))
- ;; (print "loop: patt: " patt ", tal " tal)
- (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
- (test-patt (cadr patt-parts))
- (item-patt (cadddr patt-parts))
- (test-qry (db:patt->like "testname" test-patt))
- (item-qry (db:patt->like "item_path" item-patt))
- (qry (conc "(" test-qry " AND " item-qry ")")))
- ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
- (if (null? tal)
- (string-intersperse (append (reverse res)(list qry)) " OR ")
- (loop (car tal)(cdr tal)(cons qry res)))))))
- #f))
-
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))
Index: testsmod.scm
==================================================================
--- testsmod.scm
+++ testsmod.scm
@@ -24,12 +24,374 @@
(module testsmod
*
(import scheme chicken data-structures extras)
+
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable
+ (prefix mtconfigf configf:)
+ regex srfi-13
commonmod
(prefix mtargs args:))
-(include "common_records.scm")
+(define *java-script-lib* #f)
+
+(define (init-java-script-lib)
+ (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
+ )
+
+;; A routine to map itempaths using a itemmap
+;; patha and pathb must be strings or this will fail
+;;
+;; path-b is waiting on path-a
+;;
+(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
+ (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
+ (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
+ (if itemmap
+ (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
+ (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
+ (equal? path-a path-b-mapped))
+ (equal? path-b path-a))))
+
+;; A routine to convert test/itempath using a itemmap
+;; NOTE: to process only an itempath (i.e. no prepended testname)
+;; just call db:multi-pattern-apply
+;;
+(define (db:convert-test-itempath path-in itemmap)
+ (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
+ (let* ((path-parts (string-split path-in "/"))
+ (test-name (if (null? path-parts) "" (car path-parts)))
+ (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
+ (conc test-name "/"
+ (db:multi-pattern-apply item-path itemmap))))
+
+;;======================================================================
+;; Run keys, these are used to hierarchially organise tests and run areas
+;;======================================================================
+
+(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
+ (string-intersperse keys ","))
+
+(define (args:usage . a) #f)
+
+;;======================================================================
+;; key <=> target routines
+;;======================================================================
+
+;; This invalidates using "/" in item names. Every key will be
+;; available via args:get-arg as :keyfield. Since this only needs to
+;; be called once let's use it to set the environment vars
+;;
+;; The setting of :keyfield in args should be turned off ASAP
+;;
+(define (keys:target-set-args keys target ht)
+ (if target
+ (let ((vals (string-split target "/")))
+ (if (eq? (length vals)(length keys))
+ (for-each (lambda (key val)
+ (setenv key val)
+ (if ht (hash-table-set! ht (conc ":" key) val)))
+ keys
+ vals)
+ (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
+ vals)
+ (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
+
+;; given the keys (a list of vectors or a list of keys) and a target return a keyval list
+;; keyval list ( (key1 val1) (key2 val2) ...)
+(define (keys:target->keyval keys target)
+ (let* ((targlist (string-split target "/"))
+ (numkeys (length keys))
+ (numtarg (length targlist))
+ (targtweaked (if (> numkeys numtarg)
+ (append targlist (make-list (- numkeys numtarg) ""))
+ targlist)))
+ (map (lambda (key targ)
+ (list key targ))
+ keys targtweaked)))
+
+;;======================================================================
+;; config file related routines
+;;======================================================================
+
+(define keys:config-get-fields common:get-fields)
+(define (keys:make-key/field-string confdat)
+ (let ((fields (configf:get-section confdat "fields")))
+ (string-join
+ (map (lambda (field)(conc (car field) " " (cadr field)))
+ fields)
+ ",")))
+
+;; patterns are:
+;; "rx1" "replacement1"\n
+;; "rx2" "replacement2"
+;; etc.
+;;
+(define (db:multi-pattern-apply item-path itemmap)
+ (let ((all-patts (string-split itemmap "\n")))
+ (if (null? all-patts)
+ item-path
+ (let loop ((hed (car all-patts))
+ (tal (cdr all-patts))
+ (res item-path))
+ (let* ((parts (string-split hed))
+ (patt (car parts))
+
+ (repl (if (> (length parts) 1)(cadr parts) ""))
+
+ (newr (if (and patt repl)
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port*
+ "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
+ res)
+ (string-substitute patt repl res))
+
+
+ )
+ (begin
+ (debug:print 0 *default-log-port*
+ "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
+ res))))
+ (if (null? tal)
+ newr
+ (loop (car tal)(cdr tal) newr)))))))
+
+;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
+;;
+;; genlib/testconfig sim/testconfig
+;; genlib/sch sim/sch/cell1
+;;
+;; [requirements] [requirements]
+;; mode itemwait
+;; # trim off the cell to determine what to run for genlib
+;; itemmap /.*
+;;
+;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
+;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '())
+;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/"
+;; expected -> "normal-first,normal-second/2,normal-second/"
+;; testpatt = normal-second/2
+;; waiting-test = normal-second
+;; waiton-test = normal-first
+;; itemmaps = ()
+
+(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton)
+ (cond
+ (itemized-waiton
+ (let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test))
+ (patts (string-split test-patt ","))
+ (waiting-test-len (+ (string-length waiting-test) 1))
+ (patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test
+ (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x))
+ (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
+ ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
+ ;; (print "in map, x=" x ", newpatt=" newpatt)
+ newpatt))
+ (filter (lambda (x)
+ (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
+ patts)))
+ (extended-test-patt (append patts (if (null? patts-waiton)
+ (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
+ patts-waiton)))
+ (extended-test-patt-with-toplevels
+ (fold (lambda (testpatt-item accum )
+ (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item)))
+ (cons testpatt-item
+ (if my-match
+ (cons
+ (conc (cadr my-match) "/")
+ accum)
+ accum))))
+ '()
+ extended-test-patt)))
+ (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ",")))
+ (else ;; not waiting on items, waiting on entire waiton test.
+ (let* ((patts (string-split test-patt ","))
+ (new-patts (if (member waiton-test patts)
+ patts
+ (cons waiton-test patts))))
+ (string-intersperse (delete-duplicates new-patts) ",")))))
+
+
+
+;; tests:glob-like-match
+(define (tests:glob-like-match patt str)
+ (let ((like (substring-index "%" patt)))
+ (let* ((notpatt (equal? (substring-index "~" patt) 0))
+ (newpatt (if notpatt (substring patt 1) patt))
+ (finpatt (if like
+ (string-substitute (regexp "%") ".*" newpatt #f)
+ (string-substitute (regexp "\\*") ".*" newpatt #f)))
+ (res #f))
+ ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
+ (set! res (string-match (regexp finpatt (if like #t #f)) str))
+ (if notpatt (not res) res))))
+
+;; if itempath is #f then look only at the testname part
+;;
+(define (tests:match patterns testname itempath #!key (required '()))
+ (if (string? patterns)
+ (let ((patts (append (string-split patterns ",") required)))
+ (if (null? patts) ;;; no pattern(s) means no match
+ #f
+ (let loop ((patt (car patts))
+ (tal (cdr patts)))
+ ;; (print "loop: patt: " patt ", tal " tal)
+ (if (string=? patt "")
+ #f ;; nothing ever matches empty string - policy
+ (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
+ (test-patt (cadr patt-parts))
+ (item-patt (cadddr patt-parts)))
+ ;; special case: test vs. test/
+ ;; test => "test" "%"
+ ;; test/ => "test" ""
+ (if (and (not (substring-index "/" patt)) ;; no slash in the original
+ (or (not item-patt)
+ (equal? item-patt ""))) ;; should always be true that item-patt is ""
+ (set! item-patt "%"))
+ ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
+ (if (and (tests:glob-like-match test-patt testname)
+ (or (not itempath)
+ (tests:glob-like-match (if item-patt item-patt "") itempath)))
+ #t
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal)))))))))))
+
+;; if itempath is #f then look only at the testname part
+;;
+(define (tests:match->sqlqry patterns)
+ (if (string? patterns)
+ (let ((patts (string-split patterns ",")))
+ (if (null? patts) ;;; no pattern(s) means no match, we will do no query
+ #f
+ (let loop ((patt (car patts))
+ (tal (cdr patts))
+ (res '()))
+ ;; (print "loop: patt: " patt ", tal " tal)
+ (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
+ (test-patt (cadr patt-parts))
+ (item-patt (cadddr patt-parts))
+ (test-qry (db:patt->like "testname" test-patt))
+ (item-qry (db:patt->like "item_path" item-patt))
+ (qry (conc "(" test-qry " AND " item-qry ")")))
+ ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
+ (if (null? tal)
+ (string-intersperse (append (reverse res)(list qry)) " OR ")
+ (loop (car tal)(cdr tal)(cons qry res)))))))
+ #f))
+
+;; keys list to key1,key2,key3 ...
+(define (runs:get-std-run-fields keys remfields)
+ (let* ((header (append keys remfields))
+ (keystr (conc (keys->keystr keys) ","
+ (string-intersperse remfields ","))))
+ (list keystr header)))
+
+;; make a query (fieldname like 'patt1' OR fieldname
+(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
+ (let ((patts (if (string? pattstr)
+ (string-split pattstr ",")
+ '("%"))))
+ (string-intersperse (map (lambda (patt)
+ (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
+ (conc fieldname " " wildtype " '" patt "'")))
+ (if (null? patts)
+ '("")
+ patts))
+ comparator)))
+
+;; 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
+;;
+(define (tests:get-all)
+ (let* ((test-search-path (tests:get-tests-search-path *configdat*)))
+ (tests:get-valid-tests (make-hash-table) test-search-path)))
+
+(define (tests:get-tests-search-path cfgdat)
+ (let ((paths (let ((section (if cfgdat
+ (configf:get-section cfgdat "tests-paths")
+ #f)))
+ (if section
+ (map cadr section)
+ '()))))
+ (filter (lambda (d)
+ (if (directory-exists? d)
+ d
+ (begin
+ (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
+ (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
+ #f)))
+ (append paths (list (conc *toppath* "/tests"))))))
+
+(define (tests:get-valid-tests test-registry tests-paths)
+ (if (null? tests-paths)
+ test-registry
+ (let loop ((hed (car tests-paths))
+ (tal (cdr tests-paths)))
+ (if (common:file-exists? hed)
+ (for-each (lambda (test-path)
+ (let* ((tname (last (string-split test-path "/")))
+ (tconfig (conc test-path "/testconfig")))
+ (if (and (not (hash-table-ref/default test-registry tname #f))
+ (common:file-exists? tconfig))
+ (hash-table-set! test-registry tname test-path))))
+ (glob (conc hed "/*"))))
+ (if (null? tal)
+ test-registry
+ (loop (car tal)(cdr tal))))))
+
+(define (tests:filter-test-names-not-matched test-names test-patts)
+ (delete-duplicates
+ (filter (lambda (testname)
+ (not (tests:match test-patts testname #f)))
+ test-names)))
+
+
+(define (tests:filter-test-names test-names test-patts)
+ (delete-duplicates
+ (filter (lambda (testname)
+ (tests:match test-patts testname #f))
+ test-names)))
+
+;; itemmap is a list of testname patterns to maps
+;; test1 .*/bar/(\d+) foo/\1
+;; % foo/([^/]+) \1/bar
+;;
+;; # NOTE: the line with the single % could be the result of
+;; # itemmap entry in requirements (legacy). The itemmap
+;; # requirements entry is deprecated
+;;
+(define (tests:get-itemmaps tconfig)
+ (let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap"))
+ (itemmap-table (configf:get-section tconfig "itemmap")))
+ (append (if base-itemmap
+ (list (list "%" base-itemmap))
+ '())
+ (if itemmap-table
+ itemmap-table
+ '()))))
+
+;; given a list of itemmaps (testname . map), return the first match
+;;
+(define (tests:lookup-itemmap itemmaps testname)
+ (let ((best-matches (filter (lambda (itemmap)
+ (tests:match (car itemmap) testname #f))
+ itemmaps)))
+ (if (null? best-matches)
+ #f
+ (let ((res (car best-matches)))
+ ;; (debug:print 0 *default-log-port* "res=" res)
+ (cond
+ ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
+ ((null? res) #f)
+ ((string? (cdr res)) (cdr res)) ;; it is a pair
+ ((string? (cadr res))(cadr res)) ;; it is a list
+ (else cadr res))))))
+
)