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)))))) + )