Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -11,10 +11,13 @@
http-transport.scm filedb.scm tdb.scm \
client.scm daemon.scm mt.scm \
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm \
portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
+
+# module source files
+MSRCFILES = ftail.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
@@ -22,10 +25,16 @@
GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
+
+MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
+
+mofiles/%.o : %.scm
+ mkdir -p mofiles
+ csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
@@ -41,15 +50,15 @@
PNGFILES = $(shell cd docs/manual;ls *png)
#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut
-mtest: $(OFILES) readline-fix.scm megatest.o
- csc $(CSCOPTS) $(OFILES) megatest.o -o mtest
+mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o
+ csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
-dboard : $(OFILES) $(GOFILES) dashboard.scm
- csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard
+dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES)
+ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -39,17 +39,20 @@
get-prereqs-not-met
get-count-tests-running-for-run-id
get-run-info
get-run-status
get-run-stats
+ get-run-times
get-targets
get-target
;; register-run
get-tests-tags
+ get-test-times
get-tests-for-run
get-test-id
get-tests-for-runs-mindata
+ get-tests-for-run-mindata
get-run-name-from-id
get-runs
simple-get-runs
get-num-runs
get-all-run-ids
@@ -256,18 +259,20 @@
((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
((synchash-get) (apply synchash:server-get dbstruct params))
((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
+ ((get-test-times) (apply db:get-test-times dbstruct params))
;; RUNS
((get-run-info) (apply db:get-run-info dbstruct params))
((get-run-status) (apply db:get-run-status dbstruct params))
((set-run-status) (apply db:set-run-status dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
+ ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
((get-runs) (apply db:get-runs dbstruct params))
((simple-get-runs) (apply db:simple-get-runs dbstruct params))
((get-num-runs) (apply db:get-num-runs dbstruct params))
((get-all-run-ids) (db:get-all-run-ids dbstruct))
((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
@@ -275,10 +280,11 @@
((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
((get-var) (apply db:get-var dbstruct params))
((get-run-stats) (apply db:get-run-stats dbstruct params))
+ ((get-run-times) (apply db:get-run-times dbstruct params))
;; STEPS
((get-steps-data) (apply db:get-steps-data dbstruct params))
((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -8,12 +8,12 @@
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use srfi-1 data-structures posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack
- matchable regex posix srfi-18 extras
- pkts (prefix dbi dbi:))
+ matchable pkts (prefix dbi dbi:)
+ regex)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
@@ -100,10 +100,11 @@
;;
(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)
@@ -507,11 +508,12 @@
;; S T A T E S A N D S T A T U S E S
;;======================================================================
;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-states* ;; for toggle buttons in dashboard
- '((0 "ARCHIVED")
+ '(
+ (0 "ARCHIVED")
(1 "STUCK")
(2 "KILLREQ")
(3 "KILLED")
(4 "NOT_STARTED")
(5 "COMPLETED")
@@ -519,12 +521,14 @@
(7 "REMOTEHOSTSTART")
(8 "RUNNING")
))
;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls
+;; note these statuses are sorted from better to worse.
+;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items
(define *common:std-statuses*
- '(;; (0 "DELETED")
+ '(;; (0 "DELETED")
(1 "n/a")
(2 "PASS")
(3 "SKIP")
(4 "WARN")
(5 "WAIVED")
@@ -531,17 +535,21 @@
(6 "CHECK")
(7 "STUCK/DEAD")
(8 "DEAD")
(9 "FAIL")
(10 "PREQ_FAIL")
- (11 "ABORT")))
+ (11 "PREQ_DISCARDED")
+ (12 "ABORT")))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
- '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
+ '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))
(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
'("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))
+
+(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed
+ '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))
;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items
(define *common:running-states* ;; test is either running or can be run
'("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED"))
@@ -1748,10 +1756,12 @@
key "=" delim (mungeval val) delim)))
envvars)))))
;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
+;; a value of #f means "unset this var"
+;;
(define (alist->env-vars lst)
(if (list? lst)
(let ((res '()))
(for-each (lambda (p)
(let* ((var (car p))
@@ -2314,34 +2324,67 @@
;;======================================================================
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================
-(define common:pkt-spec
- '((server . ((action . a)
- (pid . d)
- (ipaddr . i)
- (port . p)))
-
- (test . ((cpuuse . c)
- (diskuse . d)
- (item-path . i)
- (runname . r)
- (state . s)
- (target . t)
- (status . u)))))
+(define common:pkts-spec
+ '((default . ((parent . P)
+ (action . a)
+ (filename . f)))
+ (configf . ((parent . P)
+ (action . a)
+ (filename . f)))
+ (server . ((action . a)
+ (pid . d)
+ (ipaddr . i)
+ (port . p)
+ (parent . P)))
+
+ (test . ((cpuuse . c)
+ (diskuse . d)
+ (item-path . i)
+ (runname . r)
+ (state . s)
+ (target . t)
+ (status . u)
+ (parent . P)))))
(define (common:get-pkts-dirs mtconf use-lt)
(let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs")
(and use-lt
- (conc *toppath* "/lt/.pkts"))))
+ (conc (or *toppath*
+ (current-directory))
+ "/lt/.pkts"))))
(pktsdirs (if pktsdirs-str
(string-split pktsdirs-str " ")
#f)))
pktsdirs))
;; use-lt is use linktree "lt" link to find pkts dir
+(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already
+ (if (or add-only
+ (hash-table-exists? *pkts-info* 'last-parent))
+ (let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f))
+ (pktalist (if parent
+ (cons `(parent . ,parent)
+ pktalist-in)
+ pktalist-in)))
+ (let-values (((uuid pkt)
+ (alist->pkt pktalist common:pkts-spec)))
+ (hash-table-set! *pkts-info* 'last-parent uuid)
+ (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
+ (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
+ (pktsdir (car pktsdirs))) ;; assume it is there
+ (hash-table-set! *pkts-info* 'pkts-dir pktsdir)
+ pktsdir))))
+ (if (not (file-exists? pktsdir))
+ (create-directory pktsdir #t))
+ (with-output-to-file
+ (conc pktsdir "/" uuid ".pkt")
+ (lambda ()
+ (print pkt))))))))
+
(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
(let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
(pktsdir (if pktsdirs (car pktsdirs) #f))
(toppath (or (configf:lookup mtconf "scratchdat" "toppath")
toppath-in))
@@ -2358,11 +2401,11 @@
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(proc pktsdirs pktsdir pdb)
(dbi:close pdb))))))
-(define (common:load-pkts-to-db mtconf)
+(define (common:load-pkts-to-db mtconf #!key (use-lt #f))
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
@@ -2389,11 +2432,12 @@
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
(debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
pkts)))))
- pktsdirs))))
+ pktsdirs))
+ use-lt: use-lt))
(define (common:get-pkt-alists pkts)
(map (lambda (x)
(alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
pkts))
@@ -2410,5 +2454,43 @@
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
+;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
+;; execute thunk in context of environment modified as per this list
+;; restore env to prior state then return value of eval'd thunk.
+;; ** this is not thread safe **
+(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
+ (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
+ (hash-table->alist delta-env-alist-or-hash-table)
+ delta-env-alist-or-hash-table))
+ (restore-thunks
+ (filter
+ identity
+ (map (lambda (env-pair)
+ (let* ((env-var (car env-pair))
+ (new-val (cadr env-pair))
+ (current-val (get-environment-variable env-var))
+ (restore-thunk
+ (cond
+ ((not current-val) (lambda () (unsetenv env-var)))
+ ((not (string? new-val)) #f)
+ ((eq? current-val new-val) #f)
+ (else
+ (lambda () (setenv env-var current-val))))))
+ ;;(when (not (string? new-val))
+ ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
+ ;; (pp delta-env-alist)
+ ;; (exit 1))
+
+
+ (cond
+ ((not new-val) ;; modify env here
+ (unsetenv env-var))
+ ((string? new-val)
+ (setenv env-var new-val)))
+ restore-thunk))
+ delta-env-alist))))
+ (let ((rv (thunk)))
+ (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
+ rv)))
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -147,15 +147,17 @@
(temp (string-split (->string this-loc) " "))
(this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
(if (equal? this-func "BB>")
(set! location this-loc))))
stack)
- (let ((dp-args
- (append
- (list 0 *default-log-port*
- (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") )
- in-args)))
+ (let* ((color-on "\x1b[1m")
+ (color-off "\x1b[0m")
+ (dp-args
+ (append
+ (list 0 *default-log-port*
+ (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
+ in-args)))
(apply debug:print dp-args))))
(define *BBpp_custom_expanders_list* (make-hash-table))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -77,10 +77,14 @@
(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
;; read a line and process any #{ ... } constructs
(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
+
+(define (configf:system ht cmd)
+ (system cmd)
+ )
(define (configf:process-line l ht allow-system #!key (linenum #f))
(let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
@@ -92,11 +96,11 @@
(result #f)
(start-time (current-seconds))
(cmdsym (string->symbol cmdtype))
(fullcmd (case cmdsym
((scheme scm) (conc "(lambda (ht)" cmd ")"))
- ((system) (conc "(lambda (ht)(system \"" cmd "\"))"))
+ ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
((mtrah) (conc "(lambda (ht)"
" (let ((extra \"" cmd "\"))"
@@ -176,11 +180,27 @@
(configf:process-line inl ht allow-processing)))))
(if (and (string? res)
(not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
(string-substitute "\\s+$" "" res)
res))))))
-
+
+(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
+ (filter
+ (lambda (pair)
+ (let* ((var (car pair))
+ (val (cdr pair)))
+ (cons var
+ (cond
+ ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
+ (val))
+ ((procedure? val) #f)
+ ((string? val) val)
+ (else "#f")))))
+ (append
+ (hash-table-ref/default cfgdat-ht "default" '())
+ (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))
+
(define (calc-allow-system allow-system section sections)
(if sections
(and (or (equal? "default" section)
(member section sections))
allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
@@ -217,20 +237,32 @@
;; read a config file, returns hash table of alists
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
+;; allow-system:
+;; #f - do not evaluate [system
+;; #t - immediately evaluate [system and store result as string
+;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
+;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
-(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
+(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
(sections #f) (settings (make-hash-table)) (keep-filenames #f)
- (post-section-procs '()) (apply-wildcards #t))
+ (post-section-procs '()) (apply-wildcards #t) )
(debug:print 9 *default-log-port* "START: " path)
+ (if *configdat*
+ (common:save-pkt `((action . read-config)
+ (f . ,(cond ((string? path) path)
+ ((port? path) "port")
+ (else (conc path))))
+ (T . configf))
+ *configdat* #t add-only: #t))
(if (and (not (port? path))
(not (common:file-exists? path))) ;; for case where we are handed a port
(begin
(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
@@ -265,138 +297,174 @@
(lambda (section)
(if (not (member section sections))
(hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
(hash-table-keys res)))
(debug:print 9 *default-log-port* "END: " path)
- res)
+ res
+ ) ;; retval
(regex-case
inl
- (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (configf:settings ( x setting val ) (begin
- (hash-table-set! settings setting val)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
- (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
- (full-conf (if (absolute-pathname? include-file)
- include-file
- (common:nice-path
- (conc (if curr-conf-dir
- curr-conf-dir
- ".")
- "/" include-file)))))
- (if (common:file-exists? full-conf)
- (begin
- ;; (push-directory conf-dir)
- (debug:print 9 *default-log-port* "Including: " full-conf)
- (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
- ;; (pop-directory)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (begin
- (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")")
- (debug:print 2 *default-log-port* " " full-conf)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))
+ (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+
+ (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+ (configf:settings ( x setting val )
+ (begin
+ (hash-table-set! settings setting val)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))
+
+ (configf:include-rx ( x include-file )
+ (let* ((curr-conf-dir (pathname-directory path))
+ (full-conf (if (absolute-pathname? include-file)
+ include-file
+ (common:nice-path
+ (conc (if curr-conf-dir
+ curr-conf-dir
+ ".")
+ "/" include-file)))))
+ (if (common:file-exists? full-conf)
+ (begin
+ ;; (push-directory conf-dir)
+ (debug:print 9 *default-log-port* "Including: " full-conf)
+ (read-config full-conf res allow-system environ-patt: environ-patt
+ curr-section: curr-section-name sections: sections settings: settings
+ keep-filenames: keep-filenames)
+ ;; (pop-directory)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (begin
+ (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")")
+ (debug:print 2 *default-log-port* " " full-conf)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))))
(configf:script-rx ( x include-script params);; handle-exceptions
;; exn
;; (begin
;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (if (and (common:file-exists? include-script)(file-execute-access? include-script))
- (let* ((new-inp-port (open-input-pipe (conc include-script " " params))))
- (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
- ;; (print "We got here, calling read-config next. Port is: " new-inp-port)
- (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
- (close-input-port new-inp-port)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (begin
- (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
- ) ;; )
- (configf:section-rx ( x section-name ) (begin
- ;; call post-section-procs
- (for-each
- (lambda (dat)
- (let ((patt (car dat))
- (proc (cdr dat)))
- (if (string-match patt curr-section-name)
- (proc curr-section-name section-name res path))))
- post-section-procs)
- ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
- ;; NOTE: we are processing the curr-section-name, NOT section-name.
- (process-wildcards res curr-section-name)
- (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- ;; if we have the sections list then force all settings into "" and delete it later?
- ;; (if (or (not sections)
- ;; (member section-name sections))
- ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
- section-name
- #f #f)))
- (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections)
- (let ((alist (hash-table-ref/default res curr-section-name '()))
- (val-proc (lambda ()
- (let* ((start-time (current-seconds))
- (cmdres (process:cmd-run->list cmd))
- (delta (- (current-seconds) start-time))
- (status (cadr cmdres))
- (res (car cmdres)))
- (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
- (if (not (eq? status 0))
- (begin
- (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
- " output: " cmdres)))
- (if (> delta 2)
- (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
- (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
- (if (null? res)
- ""
- (string-intersperse res " "))))))
- (hash-table-set! res curr-section-name
- (config:assoc-safe-add alist
- key
- (case (calc-allow-system allow-system curr-section-name sections)
- ((return-procs) val-proc)
- ((return-string) cmd)
- (else (val-proc)))
- metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
- (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))
- (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
- (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
- (safe-setenv key fval)
- (hash-table-set! res curr-section-name
- (config:assoc-safe-add alist key fval metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
- (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '()))
- (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
- (realval (if envar
- (config:eval-string-in-environment val)
- val)))
- (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
- (if envar (safe-setenv key realval))
- (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
- (hash-table-set! res curr-section-name
- (config:assoc-safe-add alist key realval metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
+ (if (and (common:file-exists? include-script)(file-execute-access? include-script))
+ (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (new-inp-port
+ (common:with-env-vars
+ env-delta
+ (lambda ()
+ (open-input-pipe (conc include-script " " params))))))
+ (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
+ ;; (print "We got here, calling read-config next. Port is: " new-inp-port)
+ (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
+ (close-input-port new-inp-port)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (begin
+ (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
+ ) ;; )
+ (configf:section-rx ( x section-name )
+ (begin
+ ;; call post-section-procs
+ (for-each
+ (lambda (dat)
+ (let ((patt (car dat))
+ (proc (cdr dat)))
+ (if (string-match patt curr-section-name)
+ (proc curr-section-name section-name res path))))
+ post-section-procs)
+ ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
+ ;; NOTE: we are processing the curr-section-name, NOT section-name.
+ (process-wildcards res curr-section-name)
+ (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ ;; if we have the sections list then force all settings into "" and delete it later?
+ ;; (if (or (not sections)
+ ;; (member section-name sections))
+ ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
+ section-name
+ #f #f)))
+ (configf:key-sys-pr ( x key cmd )
+ (if (calc-allow-system allow-system curr-section-name sections)
+ (let ((alist (hash-table-ref/default res curr-section-name '()))
+ (val-proc (lambda ()
+ (let* ((start-time (current-seconds))
+ (local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
+ (delta (- (current-seconds) start-time))
+ (status (cadr cmdres))
+ (res (car cmdres)))
+ (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
+ (if (not (eq? status 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
+ " output: " cmdres)))
+ (if (> delta 2)
+ (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
+ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
+ (if (null? res)
+ ""
+ (string-intersperse res " "))))))
+ (hash-table-set! res curr-section-name
+ (config:assoc-safe-add alist
+ key
+ (case (calc-allow-system allow-system curr-section-name sections)
+ ((return-procs) val-proc)
+ ((return-string) cmd)
+ (else (val-proc)))
+ metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name #f #f)))
+
+ (configf:key-no-val ( x key val)
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
+ (safe-setenv key fval)
+ (hash-table-set! res curr-section-name
+ (config:assoc-safe-add alist key fval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name key #f)))
+
+ (configf:key-val-pr ( x key unk1 val unk2 )
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
+ (realval (if envar
+ (config:eval-string-in-environment val)
+ val)))
+ (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
+ (if envar (safe-setenv key realval))
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
+ (hash-table-set! res curr-section-name
+ (config:assoc-safe-add alist key realval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name key #f)))
;; if a continued line
- (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '())))
- (if var-flag ;; if set to a string then we have a continued var
- (let ((newval (conc
- (config-lookup res curr-section-name var-flag) "\n"
- ;; trim lead from the incoming whsp to support some indenting.
- (if lead
- (string-substitute (regexp lead) "" whsp)
- "")
- val)))
- ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
- (hash-table-set! res curr-section-name
- (config:assoc-safe-add alist var-flag newval metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ (configf:cont-ln-rx ( x whsp val )
+ (let ((alist (hash-table-ref/default res curr-section-name '())))
+ (if var-flag ;; if set to a string then we have a continued var
+ (let ((newval (conc
+ (config-lookup res curr-section-name var-flag) "\n"
+ ;; trim lead from the incoming whsp to support some indenting.
+ (if lead
+ (string-substitute (regexp lead) "" whsp)
+ "")
+ val)))
+ ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
+ (hash-table-set! res curr-section-name
+ (config:assoc-safe-add alist var-flag newval metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
(else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))))))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ ) ;; end loop
+ )))
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
@@ -457,10 +525,18 @@
'()
(map car sectdat))))
(define (configf:get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
+
+(define (configf:set-section-var cfgdat section var val)
+ (let ((sectdat (configf:get-section cfgdat section)))
+ (hash-table-set! cfgdat section
+ (config:assoc-safe-add sectdat var val))))
+
+ ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
+ ;; (list var val))))
(define (setup)
(let* ((configf (find-config "megatest.config"))
(config (if configf (read-config configf #f #t) #f)))
(if config
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -243,11 +243,17 @@
)))))
;; if there is a submegatest create a button to launch dashboard in that area
;;
(define (submegatest-panel dbstruct keydat testdat runname testconfig)
- (let* ((subarea (configf:lookup testconfig "setup" "submegatest"))
+ (let* ((test-run-dir (db:test-get-rundir testdat))
+ (subrun-tconf-file (conc test-run-dir "/testconfig.subrun"))
+ (subrun-tconf (if (file-exists? subrun-tconf-file)
+ (configf:read-alist subrun-tconf-file)
+ (make-hash-table)))
+ (subarea (or (configf:lookup testconfig "setup" "submegatest")
+ (configf:lookup subrun-tconf "subrun" "runarea")))
(area-exists (and subarea (common:file-exists? subarea))))
;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists)
(if subarea
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
@@ -626,15 +632,16 @@
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -v"))))
(clean-run-execute (lambda (x)
- (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname
+ (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname
+ "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
- ";megatest -target " keystring " -runname " runname
+ ";megatest -target " keystring " -runname " runname
" -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -clean-cache"
)))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -1014,11 +1014,11 @@
(testsdat-by-name (dboard:rundat-tests-by-name rundat))
(key-val-dat (dboard:rundat-key-vals rundat))
(run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
(key-vals (append key-val-dat
(list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
- (if x x "")))))
+ (if (string? x) x "")))))
(run-key (string-intersperse key-vals "\n")))
;; fill in the run header key values
;;
(let ((rown 0)
@@ -1682,11 +1682,13 @@
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
- (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
+ (key-vals (map (lambda (key)
+ (let ((val (db:get-value-by-header run-record runs-header key)))
+ (if (string? val) val "")))
(dboard:tabdat-keys tabdat)))
(run-name (db:get-value-by-header run-record runs-header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (append key-vals (list run-name))))
(if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
@@ -1711,16 +1713,20 @@
(hash-table-values tests-ht)
(lambda (a b)
(let ((a-test-name (db:test-get-testname a))
(a-item-path (db:test-get-item-path a))
(b-test-name (db:test-get-testname b))
- (b-item-path (db:test-get-item-path b)))
- (cond
- ((< 0 (string-compare3 a-test-name b-test-name)) #t)
- ((> 0 (string-compare3 a-test-name b-test-name)) #f)
- ((< 0 (string-compare3 a-item-path b-item-path)) #t)
- (else #f)))))))
+ (b-item-path (db:test-get-item-path b))
+ (a-event-time (db:test-get-event_time a))
+ (b-event-time (db:test-get-event_time b)))
+ (if (not (equal? a-test-name b-test-name))
+ (> a-event-time b-event-time)
+ (cond
+ ((< 0 (string-compare3 a-test-name b-test-name)) #t)
+ ((> 0 (string-compare3 a-test-name b-test-name)) #f)
+ ((< 0 (string-compare3 a-item-path b-item-path)) #t)
+ (else #f))))))))
(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(key-vals (rmt:get-key-vals run-id))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -221,10 +221,11 @@
(let ((db (sqlite3:open-database fname)))
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(if (not file-exists)
(begin
+
(if (and (configf:lookup *configdat* "setup" "use-wal")
(string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
(sqlite3:execute db "PRAGMA journal_mode=WAL;")
(debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
(initproc db)))
@@ -334,11 +335,11 @@
(if (and (or (not dbfexists)
(and modtimedelta
(> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
- (debug:print 4 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
+ (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
(debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
)
(debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically
@@ -1526,11 +1527,11 @@
(toplevels '())
(deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
- 7200))) ;; two hours
+ 72000))) ;; twenty hours
(db:with-db
dbstruct #f #f
(lambda (db)
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
@@ -1581,11 +1582,11 @@
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
-;; ('RUNNING','REMOTEHOSTSTART','LAUNCED'));
+;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
@@ -1984,10 +1985,34 @@
(define (db:get-rows vec)(vector-ref vec 1))
;;======================================================================
;; R U N S
;;======================================================================
+
+
+
+
+
+(define (db:get-run-times dbstruct run-patt target-patt)
+(let ((res `())
+ (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
+;(print qry)
+(db:with-db
+ dbstruct
+ #f ;; this is for the main runs db
+ #f ;; does not modify db
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (runname runtime target )
+ (set! res (cons (vector runname runtime target) res)))
+ db
+ qry
+ run-patt target-patt)
+
+ res))))
+
+
(define (db:get-run-name-from-id dbstruct run-id)
(db:with-db
dbstruct
#f ;; this is for the main runs db
@@ -2419,18 +2444,19 @@
(remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) ;; "area_id"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ","))))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
+
(db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
db
- (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
+ (conc "SELECT " keystr " FROM runs WHERE id=?;")
run-id)))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(let ((finalres (vector header res)))
;; (hash-table-set! *run-info-cache* run-id finalres)
finalres)))
@@ -2511,11 +2537,11 @@
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
(sqlite3:for-each-row
(lambda (key-val)
- (set! res (cons (list key key-val) res)))
+ (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
db qry run-id)))
keys)))
(reverse res)))
;; get key vals for a given run-id
@@ -2529,11 +2555,11 @@
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (key-val)
- (set! res (cons key-val res)))
+ (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
db qry run-id)))
keys)))
(let ((final-res (reverse res)))
(hash-table-set! *keyvals* run-id final-res)
final-res)))
@@ -3111,10 +3137,44 @@
(db:first-result-default
db
"SELECT rundir FROM tests WHERE id=?;"
#f ;; default result
test-id))))
+
+(define (db:get-test-times dbstruct run-name target)
+ (let ((res `())
+ (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
+
+ (db:with-db
+ dbstruct
+ #f ;; this is for the main runs db
+ #f ;; does not modify db
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (test-name item-path test-time target )
+ (set! res (cons (vector test-name item-path test-time) res)))
+ db
+ qry
+ run-name target)
+ res))))
+
+(define (db:get-test-times dbstruct run-name target)
+ (let ((res `())
+ (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
+
+ (db:with-db
+ dbstruct
+ #f ;; this is for the main runs db
+ #f ;; does not modify db
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (test-name item-path test-time target )
+ (set! res (cons (vector test-name item-path test-time) res)))
+ db
+ qry
+ run-name target)
+ res))))
;;======================================================================
;; S T E P S
;;======================================================================
@@ -3535,11 +3595,11 @@
db
(lambda ()
;; NB// Pass the db so it is part fo the transaction
(db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
- (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
(running (length (filter (lambda (x)
(member (dbr:counts-state x) *common:running-states*))
state-status-counts)))
(bad-not-started (length (filter (lambda (x)
(and (equal? (dbr:counts-state x) "NOT_STARTED")
@@ -3548,23 +3608,23 @@
state-status-counts)))
;; (non-completes (filter (lambda (x)
;; (not (equal? (dbr:counts-state x) "COMPLETED")))
;; state-status-counts))
(all-curr-states (common:special-sort ;; worst -> best (sort of)
- (delete-duplicates
- (if (not (equal? state "DELETED"))
- (cons state (map dbr:counts-state state-status-counts))
- (map dbr:counts-state state-status-counts)))
- *common:std-states* >))
+ (delete-duplicates
+ (if (not (equal? state "DELETED"))
+ (cons state (map dbr:counts-state state-status-counts))
+ (map dbr:counts-state state-status-counts)))
+ *common:std-states* >))
(all-curr-statuses (common:special-sort ;; worst -> best
(delete-duplicates
(if (not (equal? state "DELETED"))
(cons status (map dbr:counts-status state-status-counts))
(map dbr:counts-status state-status-counts)))
*common:std-statuses* >))
(non-completes (filter (lambda (x)
- (not (equal? x "COMPLETED")))
+ (not (member x '("DELETED" "COMPLETED"))))
all-curr-states))
(preq-fails (filter (lambda (x)
(equal? x "PREQ_FAIL"))
all-curr-statuses))
(num-non-completes (length non-completes))
@@ -3587,10 +3647,23 @@
(and (equal? newstate "NOT_STARTED")
(> num-non-completes 0)))
"STARTED")
(else
(car all-curr-statuses)))))
+
+ (debug:print-info 2 *default-log-port*
+ "\n--> probe db:set-state-status-and-roll-up-items: "
+ "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
+ "\n--> running: "running
+ "\n--> bad-not-started: "bad-not-started
+ "\n--> non-non-completes: "num-non-completes
+ "\n--> non-completes: "non-completes
+ "\n--> all-curr-states: "all-curr-states
+ "\n--> all-curr-statuses: "all-curr-statuses
+ "\n--> newstate "newstate
+ "\n--> newstatus "newstatus
+ "\n\n")
;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states)
;; " newstate: " newstate " newstatus: " newstatus)
;; NB// Pass the db so it is part of the transaction
(debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "len(sscs)="(length state-status-counts) " state-status-counts: "
@@ -3602,25 +3675,53 @@
); end debug:print
(if tl-test-id
(db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
))))))
+
(mutex-unlock! *db-transaction-mutex*)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
tr-res)))))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
-(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:map-row
- (lambda (state status count)
- (make-dbr:counts state: state status: status count: count))
- db
- "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
- run-id test-name item-path))))
+(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
+
+
+ (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path))
+ (item-state (or item-state-in (db:test-get-state test-info)))
+ (item-status (or item-status-in (db:test-get-status test-info)))
+ (other-items-count-recs (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:map-row
+ (lambda (state status count)
+ (make-dbr:counts state: state status: status count: count))
+ db
+ ;; ignore current item because we have changed its value in the current transation so this select will see the old value.
+ "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
+ run-id test-name item-path))))
+
+ ;; add current item to tally outside of sql query
+ (match-countrec-lambda (lambda (countrec)
+ (and (equal? (dbr:counts-state countrec) item-state)
+ (equal? (dbr:counts-status countrec) item-status))))
+
+ (already-have-count-rec-list
+ (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
+
+ (updated-count-rec (if (null? already-have-count-rec-list)
+ (make-dbr:counts state: item-state status: item-status count: 1)
+ (let* ((our-count-rec (car already-have-count-rec-list))
+ (new-count (add1 (dbr:counts-count our-count-rec))))
+ (make-dbr:counts state: item-state status: item-status count: new-count))))
+
+ (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
+
+ (unrelated-rec-list
+ (filter nonmatch-countrec-lambda other-items-count-recs)))
+
+ (cons updated-count-rec unrelated-rec-list)))
;; (define (db:get-all-item-states db run-id test-name)
;; (sqlite3:map-row
;; (lambda (a) a)
;; db
@@ -4158,72 +4259,125 @@
;; (conc (db:test-get-testname testdat)
;; "/"
;; (db:test-get-item-path testdat))))
running-tests) ;; calling functions want the entire data
'())
+
+ ;; collection of: for each waiton -
+ ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
+ ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
+ ;; if waiton is itemized:
+ ;; and waiton's items are not expanded, add as unmet prerequisite
+ ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
+ ;; else
+ ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
+
(if (or (not waitons)
(null? waitons))
'()
- (let* ((unmet-pre-reqs '())
- (result '()))
- (for-each
+ (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))))
+ (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
+ (ref-test-is-toplevel (equal? ref-item-path ""))
+ (ref-test-is-item (not ref-test-is-toplevel))
+ (unmet-pre-reqs '())
+ (result '())
+ (unmet-prereq-items '())
+ )
+ (for-each ; waitons
(lambda (waitontest-name)
;; by getting the tests with matching name we are looking only at the matching test
;; and related sub items
;; next should be using mt:get-tests-for-run?
- (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
+
+ (let (;(waiton-is-itemized ...)
+ ;(waiton-items-are-expanded ...)
+ (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
(ever-seen #f)
(parent-waiton-met #f)
- (item-waiton-met #f))
- (for-each
- (lambda (test) ;; BB- this is the upstream test
- ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
- (let* ((state (db:test-get-state test))
- (status (db:test-get-status test))
- (item-path (db:test-get-item-path test)) ;; BB- this is the upstream itempath
- (is-completed (equal? state "COMPLETED"))
- (is-running (equal? state "RUNNING"))
- (is-killed (equal? state "KILLED"))
- (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
+ (item-waiton-met #f)
+
+ )
+ (for-each ; test expanded from waiton
+ (lambda (waiton-test)
+ (let* ((waiton-state (db:test-get-state waiton-test))
+ (waiton-status (db:test-get-status waiton-test))
+ (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
+ (waiton-is-toplevel (equal? waiton-item-path ""))
+ (waiton-is-item (not waiton-is-toplevel))
+ (waiton-is-completed (member waiton-state *common:ended-states*))
+ (waiton-is-running (member waiton-state *common:running-states*))
+ (waiton-is-killed (member waiton-state *common:badly-ended-states*))
+ (waiton-is-ok (member waiton-status *common:well-ended-states*))
;; testname-b path-a path-b
- (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path)))
+ (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps))) ;; (equal? ref-item-path waiton-item-path)))
(set! ever-seen #t)
- (cond
- ;; case 1, non-item (parent test) is
- ((and (equal? item-path "") ;; this is the parent test of the waiton being examined
- is-completed
- (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait))))))
+ ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
+ (cond
+ ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
+ ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
+ (set! parent-waiton-met #t))
+
+ ;; case 1, non-item (parent test) is
+ ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
+ waiton-is-completed
+ ;;(BB> "cond1")
+ (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait))))))
(set! parent-waiton-met #t))
;; Special case for toplevel and KILLED
- ((and (equal? item-path "") ;; this is the parent test
- is-killed
+ ((and waiton-is-toplevel ;; this is the parent test
+ waiton-is-killed
(member 'toplevel mode))
+ ;;(BB> "cond2")
(set! parent-waiton-met #t))
;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
- ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ?????
- ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items
- same-itempath)
- (if (and is-completed is-ok)
- (set! item-waiton-met #t))
- (if (and (equal? item-path "") ;; if upstream rollup test is completed, parent-waiton-met is set
- (or is-completed is-running));; this is the parent, set it to run if completed or running ;; BB1
+ ((and ref-test-itemized-mode ref-test-is-item same-itempath)
+ ;;(BB> "cond3")
+ (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode))
+ (set! item-waiton-met #t)
+ (set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
+ (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
+ (or waiton-is-completed waiton-is-running))
(set! parent-waiton-met #t)))
;; normal checking of parent items, any parent or parent item not ok blocks running
- ((and is-completed
- (or is-ok
+ ((and waiton-is-completed
+ (or waiton-is-ok
(member 'toplevel mode)) ;; toplevel does not block on FAIL
- (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok
- (set! item-waiton-met #t)))))
- tests)
+ (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok
+ ))
+ ;;(BB> "cond4")
+ (set! item-waiton-met #t))
+
+ ((and waiton-is-completed waiton-is-ok same-itempath)
+ ;;(BB> "cond5")
+ (set! item-waiton-met #t))
+ (else
+ #t
+ ;;(BB> "condelse")
+ ))))
+ waiton-tests)
;; both requirements, parent and item-waiton must be met to NOT add item to
;; prereq's not met list
- (if (not (or parent-waiton-met item-waiton-met))
- (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; appends the string if the full record is not available
+ ;; (BB>
+ ;; "\n* waiton-tests "waiton-tests
+ ;; "\n* parent-waiton-met "parent-waiton-met
+ ;; "\n* item-waiton-met "item-waiton-met
+ ;; "\n* ever-seen "ever-seen
+ ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode
+ ;; "\n* unmet-prereq-items "unmet-prereq-items
+ ;; "\n* result (pre) "result
+ ;; "\n* ever-seen "ever-seen
+ ;; "\n")
+
+ (cond
+ ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
+ (set! result (append unmet-prereq-items result)))
+ ((not (or parent-waiton-met item-waiton-met))
+ (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
;; if the test is not found then clearly the waiton is not met...
;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
- (if (not ever-seen)
- (set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
+ ((not ever-seen)
+ (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
waitons)
(delete-duplicates result)))))
;;======================================================================
;; Just for sync, procedures to make sync easy
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -313,11 +313,12 @@
(let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations
(test-name (db:test-get-testname hed))
(item-path (db:test-get-item-path hed))
(state (db:test-get-state hed))
(status (db:test-get-status hed))
- (newitem (list test-name item-path (list test-id state status))))
+ (event-time (db:test-get-event_time hed))
+ (newitem (list test-name item-path (list test-id state status event-time))))
(if (null? tal)
(reverse (cons newitem res))
(loop (car tal)(cdr tal)(cons newitem res)))))))
(define (dcommon:tests-mindat->hash tests-mindat)
@@ -333,11 +334,14 @@
;; return 1 if status1 is better
;; return 0 if status1 and 2 are equally good
;; return -1 if status2 is better
(define (dcommon:status-compare3 status1 status2)
(let*
- ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
+ ((status-goodness-ranking (cdr ;; cdr to drop first item -- "n/a"
+ (append (map cadr *common:std-statuses*)
+ '(#f)) ;; algorithm requres last item to be #f
+ ) )
(mem1 (member status1 status-goodness-ranking))
(mem2 (member status2 status-goodness-ranking))
)
(cond
((and (not mem1) (not mem2)) 0)
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
-<meta name="generator" content="AsciiDoc 8.6.9">
+<meta name="generator" content="AsciiDoc 8.6.7">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */
/* Default font. */
@@ -84,20 +84,14 @@
margin-top: 0;
}
ul > li { color: #aaa; }
ul > li > * { color: black; }
-.monospaced, code, pre {
- font-family: "Courier New", Courier, monospace;
- font-size: inherit;
- color: navy;
+pre {
padding: 0;
margin: 0;
}
-pre {
- white-space: pre-wrap;
-}
#author {
color: #527bbd;
font-weight: bold;
font-size: 1.1em;
@@ -222,11 +216,11 @@
border-left: 3px solid #dddddd;
padding-left: 0.5em;
}
div.imageblock div.content { padding-left: 0; }
-span.image img { border-style: none; vertical-align: text-bottom; }
+span.image img { border-style: none; }
a.image:visited { color: white; }
dl {
margin-top: 0.8em;
margin-bottom: 0.8em;
@@ -417,10 +411,16 @@
/*
* xhtml11 specific
*
* */
+
+tt {
+ font-family: "Courier New", Courier, monospace;
+ font-size: inherit;
+ color: navy;
+}
div.tableblock {
margin-top: 1.0em;
margin-bottom: 1.5em;
}
@@ -450,10 +450,16 @@
/*
* html5 specific
*
* */
+
+.monospaced {
+ font-family: "Courier New", Courier, monospace;
+ font-size: inherit;
+ color: navy;
+}
table.tableblock {
margin-top: 1.0em;
margin-bottom: 1.5em;
}
@@ -530,12 +536,10 @@
}
@media print {
body.manpage div#toc { display: none; }
}
-
-
@media screen {
body {
max-width: 50em; /* approximately 80 characters wide */
margin-left: 16em;
}
@@ -1943,11 +1947,11 @@
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
-<img src="/usr/images/icons/note.png" alt="Note">
+<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
@@ -2089,11 +2093,10 @@
<div class="paragraph"><p>Then in runconfigs.config</p></div>
<div class="listingblock">
<div class="title">Example of using modified.config in a testconfig</div>
<div class="content monospaced">
<pre>cat testconfig
-
[pre-launch-env-vars]
[include modified.config]</pre>
</div></div>
</div>
</div>
@@ -2124,10 +2127,67 @@
<div class="content monospaced">
<pre># use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel.
megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'"</pre>
</div></div>
</div>
+</div>
+<div class="sect1">
+<h2 id="_nested_runs">Nested Runs</h2>
+<div class="sectionbody">
+<div class="paragraph"><p>A Megatest test can run a full Megatest run in either the same
+Megatest area or in another area. This is a powerful way of chaining
+complex suites of tests and or actions.</p></div>
+<div class="paragraph"><p>If you are not using the current area you can use ezsteps to retrieve
+and setup the sub-Megatest run area.</p></div>
+<div class="paragraph"><p>In the testconfig:</p></div>
+<div class="listingblock">
+<div class="content monospaced">
+<pre>[subrun]
+
+# Required: wait for the run or just launch it
+# if no then the run will be an automatic PASS irrespective of the actual result
+runwait yes|no
+
+# Optional: where to execute the run. Default is the current runarea
+runarea /some/path/to/megatest/area
+
+# Optional: method to use to determine pass/fail status of the run
+# auto (default) - roll up the net state/status of the sub-run
+# logpro - use the provided logpro rules, happens automatically if there is a logpro section
+# passfail auto|logpro
+# Example of logpro:
+passfail logpro
+
+# Optional:
+logpro ;; if this section exists then logpro is used to determine pass/fail
+ (expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
+ (expect:fail in "LogFileBody" = 0 "No FAILs allowed" #/FAIL/)
+
+# Optional: target translator, default is to use the parent target
+target #{shell somescript.sh}
+
+# Optional: runname translator/generator, default is to use the parent runname
+runname #{somescript.sh}
+
+# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
+testpatt %/item1,test2
+
+# Optional: contour spec, use the named contour from the megatest.config contour spec
+contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
+
+# Optional: mode-patt, use this spec for testpatt from runconfigs
+mode-patt TESTPATT
+
+# Optional: tag-expr, use this tag-expr to select tests
+tag-expr quick
+
+# Optional: (not yet implemented), propagate these actions from the parent
+# test
+# Note// default is % for all
+propagate remove-runs archive ...</pre>
+</div></div>
+</div>
</div>
<div class="sect1">
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
<div class="paragraph"><p>These routines can be called from the megatest repl.</p></div>
@@ -2185,11 +2245,10 @@
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
-Last updated
- 2017-06-25 21:04:36 MST
+Last updated 2017-08-30 10:42:37 PDT
</div>
</div>
</body>
</html>
Index: docs/manual/reference.txt
==================================================================
--- docs/manual/reference.txt
+++ docs/manual/reference.txt
@@ -608,11 +608,10 @@
Then in runconfigs.config
.Example of using modified.config in a testconfig
------------------------------
cat testconfig
-
[pre-launch-env-vars]
[include modified.config]
------------------------------
Managing Old Runs
@@ -628,10 +627,68 @@
---------------------
# use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel.
megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'"
---------------------
+Nested Runs
+-----------
+
+A Megatest test can run a full Megatest run in either the same
+Megatest area or in another area. This is a powerful way of chaining
+complex suites of tests and or actions.
+
+If you are not using the current area you can use ezsteps to retrieve
+and setup the sub-Megatest run area.
+
+In the testconfig:
+---------------
+[subrun]
+
+# Required: wait for the run or just launch it
+# if no then the run will be an automatic PASS irrespective of the actual result
+runwait yes|no
+
+# Optional: where to execute the run. Default is the current runarea
+runarea /some/path/to/megatest/area
+
+# Optional: method to use to determine pass/fail status of the run
+# auto (default) - roll up the net state/status of the sub-run
+# logpro - use the provided logpro rules, happens automatically if there is a logpro section
+# passfail auto|logpro
+# Example of logpro:
+passfail logpro
+
+# Optional:
+logpro ;; if this section exists then logpro is used to determine pass/fail
+ (expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
+ (expect:fail in "LogFileBody" = 0 "No FAILs allowed" #/FAIL/)
+
+# Optional: target translator, default is to use the parent target
+target #{shell somescript.sh}
+
+# Optional: runname translator/generator, default is to use the parent runname
+runname #{somescript.sh}
+
+# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
+testpatt %/item1,test2
+
+# Optional: contour spec, use the named contour from the megatest.config contour spec
+contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
+
+# Optional: mode-patt, use this spec for testpatt from runconfigs
+mode-patt TESTPATT
+
+# Optional: tag-expr, use this tag-expr to select tests
+tag-expr quick
+
+# Optional: (not yet implemented), propagate these actions from the parent
+# test
+# Note// default is % for all
+propagate remove-runs archive ...
+
+---------------
+
Programming API
---------------
These routines can be called from the megatest repl.
Index: docs/manual/server.png
==================================================================
--- docs/manual/server.png
+++ docs/manual/server.png
cannot compute difference between binary files
ADDED docs/megatest-desktop.png
Index: docs/megatest-desktop.png
==================================================================
--- /dev/null
+++ docs/megatest-desktop.png
cannot compute difference between binary files
DELETED file-tail.scm
Index: file-tail.scm
==================================================================
--- file-tail.scm
+++ /dev/null
@@ -1,76 +0,0 @@
-
-(use (prefix sqlite3 sqlite3:) posix typed-records)
-
-(define (open-tail-db )
- (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
- (dbpath (conc basedir "/megatest_logs.db"))
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ))
- db))
-
-(define (tail-write db fid lines)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (line)
- (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
- lines))))
-
-(define (tail-get-fid db fname)
- (let ((fid (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
- (if fid
- fid
- (begin
- (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
- (tail-get-fid db fname)))))
-
-(define (file-tail fname #!key (db-in #f))
- (let* ((inp (open-input-file fname))
- (db (or db-in (open-tail-db)))
- (fid (tail-get-fid db fname)))
- (let loop ((inl (read-line inp))
- (lines '())
- (lastwr (current-seconds)))
- (if (eof-object? inl)
- (let ((timed-out (> (- (current-seconds) lastwr) 60)))
- (if timed-out (tail-write db fid (reverse lines)))
- (sleep 1)
- (if timed-out
- (loop (read-line inp) '() (current-seconds))
- (loop (read-line inp) lines lastwr)))
- (let* ((savelines (> (length lines) 19)))
- ;; (print inl)
- (if savelines (tail-write db fid (reverse lines)))
- (loop (read-line inp)
- (if savelines
- '()
- (cons inl lines))
- (if savelines
- (current-seconds)
- lastwr)))))))
-
-;; offset -20 means get last 20 lines
-;;
-(define (tail-get-lines db fid offset count)
- (if (> offset 0)
- (map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
- (reverse ;; get N from the end
- (map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
ADDED ftail.scm
Index: ftail.scm
==================================================================
--- /dev/null
+++ ftail.scm
@@ -0,0 +1,99 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+ (
+ open-tail-db
+ tail-write
+ tail-get-fid
+ file-tail
+ )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+ (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
+ (dbpath (conc basedir "/megatest_logs.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ))
+ db))
+
+(define (tail-write db fid lines)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+ lines))))
+
+(define (tail-get-fid db fname)
+ (let ((fid (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+ (if fid
+ fid
+ (begin
+ (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+ (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+ (let* ((inp (open-input-file fname))
+ (db (or db-in (open-tail-db)))
+ (fid (tail-get-fid db fname)))
+ (let loop ((inl (read-line inp))
+ (lines '())
+ (lastwr (current-seconds)))
+ (if (eof-object? inl)
+ (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+ (if timed-out (tail-write db fid (reverse lines)))
+ (sleep 1)
+ (if timed-out
+ (loop (read-line inp) '() (current-seconds))
+ (loop (read-line inp) lines lastwr)))
+ (let* ((savelines (> (length lines) 19)))
+ ;; (print inl)
+ (if savelines (tail-write db fid (reverse lines)))
+ (loop (read-line inp)
+ (if savelines
+ '()
+ (cons inl lines))
+ (if savelines
+ (current-seconds)
+ lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+ (if (> offset 0)
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+ (reverse ;; get N from the end
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)
Index: gutils.scm
==================================================================
--- gutils.scm
+++ gutils.scm
@@ -36,10 +36,11 @@
;; ((if get-label cadr car)
(case (string->symbol state)
((COMPLETED) ;; ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 249 73" status))
+ ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
((WARN WAIVED) (list "255 172 13" status))
((SKIP) (list (gutils:get-color-spec 'SKIP) status))
((ABORT) (list "198 36 166" status))
(else (list "253 33 49" status))))
((ARCHIVED)
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -254,15 +254,18 @@
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(set! success #f)
- (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
- (debug:print 0 *default-log-port* " message: " msg)
- (debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
- (debug:print 0 *default-log-port* " call-chain: " call-chain)
- (if runremote
+ (if (debug:debug-mode 1)
+ (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
+ (debug:print 0 *default-log-port* " message: " msg)
+ (debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
+ (debug:print 0 *default-log-port* " call-chain: " call-chain)))
+ (if runremote
(remote-conndat-set! runremote #f))
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
;;; (signal (make-composite-condition
@@ -385,17 +388,30 @@
(if (and sdat
(not changed)
(> (- (current-seconds) start-time) 2))
(begin
(debug:print-info 0 *default-log-port* "Received server alive signature")
+ (common:save-pkt `((action . alive)
+ (T . server)
+ (pid . ,(current-process-id))
+ (ipaddr . ,(car sdat))
+ (port . ,(cadr sdat)))
+ *configdat* #t)
sdat)
(begin
(debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
(sleep 4)
(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
(begin
(debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
+ (common:save-pkt `((action . died)
+ (T . server)
+ (pid . ,(current-process-id))
+ (ipaddr . ,(car sdat))
+ (port . ,(cadr sdat))
+ (msg . "Transport died?"))
+ *configdat* #t)
(exit))
(loop start-time
(equal? sdat last-sdat)
sdat)))))))
(iface (car server-info))
@@ -502,11 +518,14 @@
;; (/ *total-non-write-delay*
;; *number-non-write-queries*))
;; " ms")
(db:print-current-query-stats)
-
+ (common:save-pkt `((action . exit)
+ (T . server)
+ (pid . ,(current-process-id)))
+ *configdat* #t)
(debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
(exit)))
;; all routes though here end in exit ...
;;
@@ -539,10 +558,14 @@
(let* ((num-alive (server:get-num-alive (server:get-list *toppath*))))
(if (> num-alive 3)
(begin
(cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up"))
(exit))))
+ (common:save-pkt `((action . start)
+ (T . server)
+ (pid . ,(current-process-id)))
+ *configdat* #t)
(let* ((th2 (make-thread (lambda ()
(debug:print-info 0 *default-log-port* "Server run thread started")
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -79,20 +79,31 @@
#f)))
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
(stepinfo (cadr ezstep))
- (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
- (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
+ ;; (let ((info (cadr ezstep)))
+ ;; (if (proc? info) "" info)))
+ ;; (stepproc (let ((info (cadr ezstep)))
+ ;; (if (proc? info) info #f)))
+ (stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
+ (stepparams (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
+ (paramparts (if (string? stepparams)
+ (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
+ '()))
+ (subrun (alist-ref "subrun" paramparts equal?))
(stepcmd (list-ref stepparts 3))
(script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
(logpro-file (conc stepname ".logpro"))
(html-file (conc stepname ".html"))
(dat-file (conc stepname ".dat"))
(tconfig-logpro (configf:lookup testconfig "logpro" stepname))
(logpro-used (common:file-exists? logpro-file)))
+ (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
+ ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
+
(if (and tconfig-logpro
(not logpro-used)) ;; no logpro file found but have a defn in the testconfig
(begin
(with-output-to-file logpro-file
(lambda ()
@@ -101,11 +112,11 @@
(print tconfig-logpro)))
(set! logpro-used #t)))
;; NB// can safely assume we are in test-area directory
(debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
- " stepparms: " stepparms " stepcmd: " stepcmd)
+ " stepparams: " stepparams " stepcmd: " stepcmd)
;; ;; first source the previous environment
;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh")
;; (get-environment-variable "SHELL")) ".csh" ".sh"))))
;; (if (and prevstep (common:file-exists? prev-env))
@@ -119,12 +130,19 @@
;; now launch the actual process
(call-with-environment-variables
(list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
(lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
(let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1
- (pid (process-run "/bin/bash" (list "-c" cmd))))
-
+ (pid #f))
+ (let ((proc (lambda ()
+ (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
+ (if subrun
+ (begin
+ (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
+ (common:without-vars proc "^MT_.*"))
+ (proc)))
+
(with-output-to-file "Makefile.ezsteps"
(lambda ()
(print stepname ".log :")
(print "\t" cmd)
(if (common:file-exists? (conc stepname ".logpro"))
@@ -240,11 +258,11 @@
(launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
(tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
)))
logpro-used))
-(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m)
+(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
;; (let-values
;; (((pid exit-status exit-code)
;; (run-n-wait fullrunscript)))
;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
;; Since we should have a clean slate at this time there is no need to do
@@ -274,11 +292,11 @@
(thread-sleep! 2)
(loop (+ i 1)))
)))))
;; then, if runscript ran ok (or did not get called)
;; do all the ezsteps (if any)
- (if ezsteps
+ (if (or ezsteps subrun)
(let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
;; ezstep names need a full re-eval here.
(tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
(ezstepslst (if (hash-table? testconfig)
@@ -293,29 +311,91 @@
;; after all that, still no testconfig? Time to abort
(if (not testconfig)
(begin
(debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
(exit 1)))
- (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
- ;; if ezsteps was defined then we are sure to have at least one step but check anyway
- (if (not (> (length ezstepslst) 0))
- (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
- (let loop ((ezstep (car ezstepslst))
- (tal (cdr ezstepslst))
- (prevstep #f))
- ;; check exit-info (vector-ref exit-info 1)
- (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
- (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
- (stepname (car ezstep)))
- ;; if logpro-used read in the stepname.dat file
- (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
- (launch:load-logpro-dat run-id test-id stepname))
- (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
- (if (not (null? tal))
- (loop (car tal) (cdr tal) stepname))
- (debug:print 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
- (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))
+
+ ;; create a proc for the subrun if requested, save that proc in the ezsteps table as the last entry
+ ;; 1. get section [runarun]
+ ;; 2. unset MT_* vars
+ ;; 3. fix target
+ ;; 4. fix runname
+ ;; 5. fix testpatt or calculate it from contour
+ ;; 6. launch the run
+ ;; 7. roll up the run result and or roll up the logpro processed result
+ (if (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested
+ (let* ((runarea (let ((ra (configf:lookup testconfig "subrun" "runarea")))
+ (if ra ;; when runarea is not set we default to *toppath*. However
+ ra ;; we need to force the setting in the testconfig so it will
+ (begin ;; be preserved in the testconfig.subrun file
+ (configf:set-section-var testconfig "subrun" "runarea" *toppath*)
+ *toppath*))))
+ (passfail (configf:lookup testconfig "subrun" "passfail"))
+ (target (or (configf:lookup testconfig "subrun" "target") (get-environment-variable "MT_TARGET")))
+ (runname (or (configf:lookup testconfig "subrun" "runname")(get-environment-variable "MT_RUNNAME")))
+ (contour (configf:lookup testconfig "subrun" "contour"))
+ (testpatt (configf:lookup testconfig "subrun" "testpatt"))
+ (mode-patt (configf:lookup testconfig "subrun" "mode-patt"))
+ (tag-expr (configf:lookup testconfig "subrun" "tag-expr"))
+ (run-wait (configf:lookup testconfig "subrun" "runwait"))
+ (logpro (configf:lookup testconfig "subrun" "logpro"))
+ (compact-stem (string-substitute "[/*]" "_" (conc target "-" runname "-" (or testpatt mode-patt tag-expr))))
+ (log-file (conc compact-stem ".log"))
+ (mt-cmd (conc "megatest -run -target " target
+ " -runname " runname
+ (conc " -start-dir " runarea) ;; (if runarea runarea *toppath*))
+ (if testpatt (conc " -testpatt " testpatt) "")
+ (if mode-patt (conc " -modepatt " mode-patt) "")
+ (if tag-expr (conc " -tag-expr" tag-expr) "")
+ (if (equal? run-wait "yes") " -run-wait " "")
+ " -log " log-file)))
+ ;; change directory to runarea, create it if needed, we do NOT create the directory
+ ;; (if runarea
+ ;; (if (directory-exists? runarea)
+ ;; (change-directory runarea)
+ ;; (begin
+ ;; (debug:print 0 *default-log-port* "ERROR: for sub-megatest run the runarea \"" runarea "\" does not exist! EXITING.")
+ ;; (exit 1))))
+ ;; (let ((subrun (conc *toppath* "/subrun") #t))
+ ;; (create-directory subrun)
+ ;; (change-directory subrun)))
+
+ ;; by this point we are in the right place to run the subrun and we have a Megatest command to run
+ ;; (filter (lambda (x)(string-match "MT_.*" (car x))) (get-environment-variables))
+ ;; (common:without-vars mt-cmd "^MT_.*")
+ (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"")
+ (set! ezsteps #t) ;; set the needed flag
+ (set! ezstepslst (append (or ezstepslst '())
+ (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))
+ (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun
+ (if runarea (configf:set-section-var testconfig "setup" "submegatest" runarea))
+ (configf:write-alist testconfig "testconfig.subrun")
+ ))
+
+ ;; process the ezsteps
+ (if ezsteps
+ (begin
+ (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
+ ;; if ezsteps was defined then we are sure to have at least one step but check anyway
+ (if (not (> (length ezstepslst) 0))
+ (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
+ (let loop ((ezstep (car ezstepslst))
+ (tal (cdr ezstepslst))
+ (prevstep #f))
+ (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
+ ;; check exit-info (vector-ref exit-info 1)
+ (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
+ (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
+ (stepname (car ezstep)))
+ ;; if logpro-used read in the stepname.dat file
+ (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
+ (launch:load-logpro-dat run-id test-id stepname))
+ (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
+ (if (not (null? tal))
+ (loop (car tal) (cdr tal) stepname))
+ (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
+ (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))))
(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
(let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
(start-seconds (current-seconds))
(calc-minutes (lambda ()
@@ -423,10 +503,11 @@
(top-path (assoc/default 'toppath cmdinfo))
(work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(ezsteps (assoc/default 'ezsteps cmdinfo))
+ (subrun (assoc/default 'subrun cmdinfo))
;; (runremote (assoc/default 'runremote cmdinfo))
;; (transport (assoc/default 'transport cmdinfo)) ;; not used
;; (serverinf (assoc/default 'serverinf cmdinfo))
;; (port (assoc/default 'port cmdinfo))
(serverurl (assoc/default 'serverurl cmdinfo))
@@ -453,108 +534,73 @@
(let ((fulln (conc work-area "/" runscript)))
(if (and (common:file-exists? fulln)
(file-execute-access? fulln))
fulln
runscript))))) ;; assume it is on the path
- ) ;; (rollup-status 0)
+ (check-work-area (lambda ()
+ ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
+ (let loop ((count 0))
+ (if (or (common:directory-exists? work-area)
+ (> count 10))
+ (change-directory work-area)
+ (begin
+ (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
+ (thread-sleep! 10)
+ (loop (+ count 1)))))
+
+ (if (not (string=? (common:real-path work-area)(common:real-path (current-directory))))
+ (begin
+ (debug:print 0 *default-log-port*
+ "INFO: we are expecting to be in directory " work-area "\n"
+ " but we are actually in the directory " (current-directory) "\n"
+ " doing another change dir.")
+ (change-directory work-area)))
+
+ ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
+ (let ((files (glob (conc testpath "/*")))
+ (bad-files '()))
+ (for-each
+ (lambda (fullname)
+ (let* ((fname (pathname-strip-directory fullname))
+ (targn (conc work-area "/" fname)))
+ (if (not (file-exists? targn))
+ (set! bad-files (cons fname bad-files)))))
+ files)
+ (if (not (null? bad-files))
+ (begin
+ (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
+ (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
+ (launch:test-copy testpath work-area))))
+ ;; one more time, change to the work-area directory
+ (change-directory work-area)))
+ ) ;; let*
+
+ (if contour (setenv "MT_CONTOUR" contour))
+
+ ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
+ ;;
+ (setenv "MT_TESTSUITENAME" areaname)
+ (setenv "MT_RUN_AREA_HOME" top-path)
+ (set! *toppath* top-path)
+ (change-directory *toppath*) ;; temporarily switch to the run area home
+ (setenv "MT_TEST_RUN_DIR" work-area)
+
+ (launch:setup) ;; should be properly in the run area home now
(if contour (setenv "MT_CONTOUR" contour))
;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
;;
(setenv "MT_TESTSUITENAME" areaname)
(setenv "MT_RUN_AREA_HOME" top-path)
(set! *toppath* top-path)
+ (change-directory *toppath*) ;; temporarily switch to the run area home
(setenv "MT_TEST_RUN_DIR" work-area)
- ;; ;; On NFS it can be slow and unreliable to get needed startup information.
- ;; ;; i. Check if we are on the homehost, if so, proceed
- ;; ;; ii. Check if host and port passed in via CMDINFO are valid and if
- ;; ;; possible use them.
- ;; (let ((bestadrs (server:get-best-guess-address (get-host-name)))
- ;; (needcare #f))
- ;; (if (equal? homehost bestadrs) ;; we are likely on the homehost
- ;; (debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost)
- ;; (let ((host-port (if serverurl (string-split serverurl ":") #f)))
- ;; (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote*
- ;; (if (string? homehost)
- ;; (if (and host-port
- ;; (> (length host-port) 1))
- ;; (let* ((host (car host-port))
- ;; (port (cadr host-port))
- ;; (start-res (http-transport:client-connect host port))
- ;; (ping-res (rmt:login-no-auto-client-setup start-res)))
- ;; (if (and start-res
- ;; ping-res)
- ;; ;; (begin ;; let ((url (http-transport:server-dat-make-url start-res)))
- ;; (begin
- ;; (remote-conndat-set! *runremote* start-res)
- ;; ;; (remote-server-url-set! *runremote* url)
- ;; ;; (if (server:ping url)
- ;; (debug:print-info 0 *default-log-port* "connected to " host ":" port " using CMDINFO data."))
- ;; (begin
- ;; (debug:print-info 0 *default-log-port* "have CMDINFO data but failed to connect to " host ":" port)
- ;; (set! *runremote* #f))
- ;; ;; (remote-conndat-set! *runremote* #f))
- ;; ))
- ;; (begin
- ;; (set! *runremote* #f)
- ;; (debug:print-info 0 *default-log-port* (if host-port
- ;; (conc "received invalid host-port information " host-port)
- ;; "no host-port information received"))
- ;; ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare.
- ;; (set! needcare #t)))
- ;; (begin
- ;; (set! *runremote* #f)
- ;; (debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.")
- ;; (set! needcare #t)))))
- ;; (if needcare ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host
- ;; (let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory
- ;; (handle-exceptions
- ;; exn
- ;; (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn))
- ;; (create-directory logdir #t)))))
- ;;
- ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
- (let loop ((count 0))
- (if (or (common:directory-exists? work-area)
- (> count 10))
- (change-directory work-area)
- (begin
- (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
- (thread-sleep! 10)
- (loop (+ count 1)))))
-
- (if (not (string=? (common:real-path work-area)(common:real-path (current-directory))))
- (begin
- (debug:print 0 *default-log-port*
- "INFO: we are expecting to be in directory " work-area "\n"
- " but we are actually in the directory " (current-directory) "\n"
- " doing another change dir.")
- (change-directory work-area)))
-
- ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
- (let ((files (glob (conc testpath "/*")))
- (bad-files '()))
- (for-each
- (lambda (fullname)
- (let* ((fname (pathname-strip-directory fullname))
- (targn (conc work-area "/" fname)))
- (if (not (file-exists? targn))
- (set! bad-files (cons fname bad-files)))))
- files)
- (if (not (null? bad-files))
- (begin
- (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
- (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
- (launch:test-copy testpath work-area))))
-
- ;; one more time, change to the work-area directory
- (change-directory work-area)
-
- (launch:setup) ;; should be properly in the top-path now
- (set! tconfigreg (tests:get-all))
+ (launch:setup) ;; should be properly in the run area home now
+
+ (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
(let ((sighand (lambda (signum)
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(if (eq? signum signal/stop)
(debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
@@ -614,10 +660,14 @@
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
+ ;; validate that the test run area is available
+ (check-work-area)
+
+ ;; still need to go back to run area home for next couple steps
(change-directory *toppath*)
;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This
;; seems non-ideal but could well break stuff
;; BUG? BUG? BUG?
@@ -625,20 +675,22 @@
(let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
(wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists
;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; Now have runconfigs data loaded, set environment vars
- (for-each (lambda (section)
- (for-each (lambda (varval)
- (let ((var (car varval))
- (val (cadr varval)))
- (if (and (string? var)(string? val))
- (begin
- (setenv var (config:eval-string-in-environment val))) ;; val)
- (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
- (configf:get-section rconfig section)))
- (list "default" target)))
+ (for-each
+ (lambda (section)
+ (for-each
+ (lambda (varval)
+ (let ((var (car varval))
+ (val (cadr varval)))
+ (if (and (string? var)(string? val))
+ (begin
+ (setenv var (config:eval-string-in-environment val))) ;; val)
+ (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
+ (configf:get-section rconfig section)))
+ (list "default" target)))
;;(bb-check-path msg: "launch:execute post block 1")
;; NFS might not have propagated the directory meta data to the run host - give it time if needed
(let loop ((count 0))
(if (or (common:file-exists? work-area)
@@ -646,10 +698,13 @@
(change-directory work-area)
(begin
(debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
(thread-sleep! 10)
(loop (+ count 1)))))
+
+ ;; now we can switch to the work-area?
+ (change-directory work-area)
;;(bb-check-path msg: "launch:execute post block 1.5")
;; (change-directory work-area)
(set! keyvals (keys:target->keyval keys target))
;; apply pre-overrides before other variables. The pre-override vars must not
;; clobbers things from the official sources such as megatest.config and runconfigs.config
@@ -721,10 +776,16 @@
;; We are about to actually kick off the test
;; so this is a good place to remove the records for
;; any previous runs
;; (db:test-remove-steps db run-id testname itemdat)
+ ;; now is also a good time to write the .testconfig file
+ (let* ((tconfig-fname (conc work-area "/.testconfig"))
+ (tconfig-tmpfile (conc tconfig-fname ".tmp"))
+ (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t))) ;; 'return-procs)))
+ (configf:write-alist tconfig tconfig-tmpfile)
+ (file-move tconfig-tmpfile tconfig-fname #t))
;;
(let* ((m (make-mutex))
(kill-job? #f)
(exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
(job-thread #f)
@@ -731,11 +792,11 @@
;; (keep-going #t)
(misc-flags (let ((ht (make-hash-table)))
(hash-table-set! ht 'keep-going #t)
ht))
(runit (lambda ()
- (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m)))
+ (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)))
(monitorjob (lambda ()
(launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
(th1 (make-thread monitorjob "monitor job"))
(th2 (make-thread runit "run job")))
(set! job-thread th2)
@@ -1057,11 +1118,11 @@
;; one more attempt to cache the configs for future reading
(let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
(rccachef (cdr cachefiles)))
- ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
+ ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
;; TODO - consider 1) using simple-lock to bracket cache write
;; 2) cache in hash on server, since need to do rmt: anyway to lock.
(if (and rccachef *runconfigdat* (not (common:file-exists? rccachef)))
(common:fail-safe
(lambda ()
@@ -1341,11 +1402,12 @@
(if (equal? ush "no") ;; must use "no" to NOT use shell
#f
ush)
#t))) ;; default is yes
(runscript (config-lookup tconfig "setup" "runscript"))
- (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big
+ (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag
+ (subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun
;; (diskspace (config-lookup tconfig "requirements" "diskspace"))
;; (memory (config-lookup tconfig "requirements" "memory"))
;; (hosts (config-lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed
(remote-megatest (config-lookup *configdat* "setup" "executable"))
(run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim")
@@ -1425,11 +1487,12 @@
(list 'run-id run-id )
(list 'test-id test-id )
;; (list 'item-path item-path )
(list 'itemdat itemdat )
(list 'megatest remote-megatest)
- (list 'ezsteps ezsteps)
+ (list 'ezsteps ezsteps)
+ (list 'subrun subrun)
(list 'target mt_target)
(list 'contour contour)
(list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
(list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '()))
(list 'set-vars (if params (hash-table-ref/default params "-setvars" #f)))
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.6503)
+(define megatest-version 1.6504)
Index: megatest.config
==================================================================
--- megatest.config
+++ megatest.config
@@ -20,11 +20,11 @@
# the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing
# ext-tests path=ext-tests; targtrans=prefix-contour;
ext path=ext-tests
[contours]
-# mode-patt/tag-expr
+# selector=tag-expr/mode-patt
quick areas=ext; selector=/QUICKPATT
quick2 areafn=check-area; selector=/QUICKPATT
# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
# full areas=fullrun,ext-tests; selector=MAXPATT/
# short areas=fullrun,ext-tests; selector=MAXPATT/
@@ -52,5 +52,7 @@
script nbfake echo
[server]
timeout 1
+
+[include local.config]
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -42,10 +42,12 @@
(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!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -213,10 +215,17 @@
-o : output file for refdb2dat (defaults to stdout)
-archive cmd : archive runs specified by selectors to one of disks specified
in the [archive-disks] section.
cmd: keep-html, restore, save, save-remove
-generate-html : create a simple html tree for browsing your runs
+ -list-run-time : list time requered to complete runs. It supports following switches
+ -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
+ -list-test-time : list time requered to complete each test in a run. It following following arguments
+ -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
+
+
+
Diff report
-diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
and either -diff-email or -diff-html)
-src-target <target>
@@ -283,10 +292,12 @@
":expected"
":tol"
":units"
;; misc
"-start-dir"
+ "-run-patt"
+ "-target-patt"
"-contour"
"-area-tag"
"-server"
"-transport"
"-port"
@@ -363,11 +374,12 @@
"-kill-servers"
"-run-wait" ;; wait on a run to complete (i.e. no RUNNING)
"-one-pass" ;;
"-local" ;; run some commands using local db access
"-generate-html"
-
+ "-list-run-time"
+ "-list-test-time"
;; misc queries
"-list-disks"
"-list-targets"
"-list-db-targets"
"-show-runconfig"
@@ -391,11 +403,10 @@
"-convert-to-norm"
"-convert-to-old"
"-import-megatest.db"
"-sync-to-megatest.db"
-
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
"-diff-rep"
@@ -1609,11 +1620,11 @@
(lambda (target runname keys keyvals)
(if (args:get-arg "-rerun-clean") ;; first set states/statuses correct
(let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
"KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
(statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
- "FAIL,INCOMPLETE,ABORT,CHECK,DEAD")))
+ "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
@@ -2227,10 +2238,20 @@
(if (args:get-arg "-sync-to")
(let ((toppath (launch:setup)))
(tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
(set! *didsomething* #t)))
+(if (args:get-arg "-list-test-time")
+ (let* ((toppath (launch:setup)))
+ (task:get-test-times)
+ (set! *didsomething* #t)))
+
+(if (args:get-arg "-list-run-time")
+ (let* ((toppath (launch:setup)))
+ (task:get-run-times)
+ (set! *didsomething* #t)))
+
(if (args:get-arg "-generate-html")
(let* ((toppath (launch:setup)))
(if (tests:create-html-tree #f)
(debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html")
(debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
Index: mt-pg.sql
==================================================================
--- mt-pg.sql
+++ mt-pg.sql
@@ -21,10 +21,14 @@
DROP TABLE IF EXISTS test_data;
DROP TABLE IF EXISTS test_rundat;
DROP TABLE IF EXISTS archives;
DROP TABLE IF EXISTS session_vars;
DROP TABLE IF EXISTS sessions;
+DROP TABLE IF EXISTS tags;
+DROP TABLE IF EXISTS users;
+DROP TABLE IF EXISTS webviews;
+DROP TABLE IF EXISTS area_tags;
CREATE TABLE IF NOT EXISTS session_vars (
id SERIAL PRIMARY KEY,
session_id INTEGER,
page TEXT,
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -177,38 +177,51 @@
(event-time (db:test-get-event_time test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat))))
;; (mutex-lock! *triggers-mutex*)
- (if (and test-name
- test-rundir) ;; #f means no dir set yet
- ;; (common:file-exists? test-rundir)
- ;; (directory? test-rundir))
- (call-with-environment-variables
- (list (cons "MT_TEST_NAME" (or test-name "no such test"))
- (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
- (cons "MT_ITEMPATH" (or item-path "")))
- (lambda ()
- (if (directory-exists? test-rundir)
- (push-directory test-rundir)
- (push-directory *toppath*))
- (set! tconfig (mt:lazy-read-test-config test-name))
- (for-each (lambda (trigger)
- (let* ((munged-trigger (string-translate trigger "/ " "--"))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
+ "\n error: " ((condition-property-accessor 'exn 'message) exn)
+ "\n test-rundir="test-rundir
+ "\n test-name="test-name
+ "\n item-path="item-path
+ "\n state="state
+ "\n status="status
+ "\n")
+ (print-call-chain (current-error-port))
+ #f)
+ (if (and test-name
+ test-rundir) ;; #f means no dir set yet
+ ;; (common:file-exists? test-rundir)
+ ;; (directory? test-rundir))
+ (call-with-environment-variables
+ (list (cons "MT_TEST_NAME" (or test-name "no such test"))
+ (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
+ (cons "MT_ITEMPATH" (or item-path "")))
+ (lambda ()
+ (if (directory-exists? test-rundir)
+ (push-directory test-rundir)
+ (push-directory *toppath*))
+ (set! tconfig (mt:lazy-read-test-config test-name))
+ (for-each (lambda (trigger)
+ (let* ((munged-trigger (string-translate trigger "/ " "--"))
(logname (conc "last-trigger-" munged-trigger ".log")))
- ;; first any triggers from the testconfig
- (let ((cmd (configf:lookup tconfig "triggers" trigger)))
- (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
- ;; next any triggers from megatest.config
- (let ((cmd (configf:lookup *configdat* "triggers" trigger)))
- (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
- (list
- (conc state "/" status)
- (conc state "/")
- (conc "/" status)))
+ ;; first any triggers from the testconfig
+ (let ((cmd (configf:lookup tconfig "triggers" trigger)))
+ (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
+ ;; next any triggers from megatest.config
+ (let ((cmd (configf:lookup *configdat* "triggers" trigger)))
+ (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
+ (list
+ (conc state "/" status)
+ (conc state "/")
+ (conc "/" status)))
(pop-directory))
- ))
+ )))
;; (mutex-unlock! *triggers-mutex*)
)))))
;;======================================================================
;; S T A T E A N D S T A T U S F O R T E S T S
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -115,10 +115,11 @@
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
areas, contours, setup : show areas, contours or setup section from megatest.config
+ gendot : generate a graphviz dot file from pkts.
Contour actions:
process : runs import, rungen and dispatch
Trigger propagation actions:
@@ -1165,10 +1166,11 @@
(print "No section \"" (car remargs) "\" found")))
(print "ERROR: list requires section parameter; areas, setup or contours")))
((gendot)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat)))
+ (common:load-pkts-to-db mtconf use-lt: #t) ;; need to NOT do this by default ...
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir conn)
;; pktspec display-fields
(make-report "out.dot" conn
@@ -1259,8 +1261,8 @@
(repl)
(load (args:get-arg "-load")))))
#|
(define mtconf (car (simple-setup #f)))
-(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
+(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -74,16 +74,19 @@
(let* ((fh (open-input-pipe cmd))
(res (port-proc->list fh proc))
(status (close-input-pipe fh)))
(if (eq? status 0) res #f)))
-(define (process:cmd-run->list cmd)
- (let* ((fh (open-input-pipe cmd))
- (res (port->list fh))
- (status (close-input-pipe fh)))
- (list res status)))
-
+(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
+ (common:with-env-vars
+ delta-env-alist-or-hash-table
+ (lambda ()
+ (let* ((fh (open-input-pipe cmd))
+ (res (port->list fh))
+ (status (close-input-pipe fh)))
+ (list res status)))))
+
(define (port->list fh)
(if (eof-object? fh) #f
(let loop ((curr (read-line fh))
(result '()))
(if (not (eof-object? curr))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -144,10 +144,11 @@
(rmt:send-receive cmd rid params attemptnum: attemptnum))
;;DOT CASE5 [label="local\nread"];
;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
;;DOT CASE5 -> "rmt:open-qry-close-locally";
+
;; 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*)
@@ -499,10 +500,14 @@
(define (rmt:get-targets)
(rmt:send-receive 'get-targets #f '()))
(define (rmt:get-target run-id)
(rmt:send-receive 'get-target run-id (list run-id)))
+
+(define (rmt:get-run-times runpatt targetpatt)
+ (rmt:send-receive 'get-run-times #f (list runpatt targetpatt )))
+
;;======================================================================
;; T E S T S
;;======================================================================
@@ -550,10 +555,13 @@
;; get stuff via synchash
(define (rmt:synchash-get run-id proc synckey keynum params)
(rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
+(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
+ (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
+
;; IDEA: Threadify these - they spend a lot of time waiting ...
;;
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
(let ((multi-run-mutex (make-mutex))
(run-id-list (if run-ids
@@ -677,10 +685,13 @@
(rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
(define (rmt:get-raw-run-stats run-id)
(rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
+(define (rmt:get-test-times runname target)
+ (rmt:send-receive 'get-test-times #f (list runname target )))
+
;;======================================================================
;; R U N S
;;======================================================================
(define (rmt:get-run-info run-id)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -184,19 +184,23 @@
(hash-table-set! *runs:denoise* key currtime)
#t)
#f)))
(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
+
;; Take advantage of a good place to exit if running the one-pass methodology
(if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
(args:get-arg "-one-pass"))
(exit 0))
- (thread-sleep! (cond
+
+ (thread-sleep! (cond ;; BB: check with Matt. Should this sleep move to cond clauses below where we determine we have too many jobs running rather than each time the and condition above is true (which seems like always)?
((> (runs:dat-can-run-more-tests-count runsdat) 20)
(if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
- 2);; obviously haven't had any work to do for a while
+ (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.1) ;; was 2
+ );; obviously haven't had any work to do for a while
(else 0)))
+
(let* ((num-running (rmt:get-count-tests-running run-id))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
@@ -207,11 +211,11 @@
(begin
(debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(set! *last-num-running-tests* num-running)))
(if (not (eq? 0 *globalexitstatus*))
(list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)
- (let ((can-not-run-more (cond
+ (let* ((can-not-run-more (cond
;; if max-concurrent-jobs is set and the number running is greater
;; than it then cannot run more jobs
((and max-concurrent-jobs (>= num-running max-concurrent-jobs))
(if (runs:lownoise "mcj msg" 60)
(debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running
@@ -303,10 +307,20 @@
(debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
(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)
+ (let* ((tests-in-testpatt
+ (map
+ (lambda (test-patt-item)
+ (car (string-split test-patt-item "/")))
+ (string-split test-patt ",")))
+ (waitors-upon-not-mentioned (lset-difference equal? waitors-upon tests-in-testpatt)))
+ (null? waitors-upon-not-mentioned)))
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
@@ -322,10 +336,11 @@
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
(test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
(required-tests #f) ;; Put fully qualified test/testpath names in this list to be done
+ (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test.
(task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
;; (tdbdat (tasks:open-db))
(config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
(allowed-tests #f))
@@ -467,13 +482,15 @@
;;======================================================================
(if (not (null? test-names)) ;; BEGIN test-names loop
(let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
+ (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
- (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
+ (let*-values (((waitons waitors config)
+ (tests:get-waitons hed all-tests-registry)))
(debug:print-info 8 *default-log-port* "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (or (member hed waitons)
(member hed waitors))
@@ -481,11 +498,11 @@
(debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
(set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
;; (items (items:get-items-from-config config)))
- (if (not (hash-table-ref/default test-records hed #f))
+ (if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once
(hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue
hed (vector hed ;; 0 ;; testname
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
@@ -492,20 +509,31 @@
(tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items
#f ;; itemsdat 5
#f ;; spare - used for item-path
waitors ;;
)))
- (for-each
+ ;; update waitors-upon here
+ (for-each
+ (lambda (waiton)
+ (let* ((current-waitors-upon (hash-table-ref/default waitors-upon waiton '())))
+ (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] is "current-waitors-upon )
+ (when (not (member hed current-waitors-upon))
+ (debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] << "hed )
+ (hash-table-set! waitors-upon waiton (cons hed current-waitors-upon)))))
+ (if (list? waitons) waitons '()))
+ (debug:print-info 8 *default-log-port* " process waitons&waitors of "hed": "(delete-duplicates (append waitons waitors)))
+ (for-each
(lambda (waiton)
(if (and waiton (not (member waiton test-names)))
- (let* ((waiton-record (hash-table-ref/default test-records waiton #f))
+ (let* ((waitors-in-testpatt (runs:testpatts-mention-waitors-upon? test-patts (hash-table-ref/default waitors-upon waiton '())))
+ (waiton-record (hash-table-ref/default test-records waiton #f))
(waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f))
(waiton-itemized (and waiton-tconfig
(or (hash-table-ref/default waiton-tconfig "items" #f)
(hash-table-ref/default waiton-tconfig "itemstable" #f))))
(itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap"))
- (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) ;; BB: items expanded here.
+ (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) ;; BB: items expanded here - chained-waiton goes awry by now.
(debug:print-info 0 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
;; is this satisfied by merely appending "/" to the waiton name added to the list?
;;
@@ -514,22 +542,25 @@
;; if we have this waiton already processed once we can analzye it for extending
;; tests to be run, since we can't properly process waitons unless they have been
;; initially added we add them again to be processed on second round AND add the hed
;; back in to also be processed on second round
;;
- (if waiton-tconfig
- (begin
- (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
- (if waiton-itemized
- (begin
- (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts)
- (set! required-tests (cons (conc waiton "/") required-tests))
- (set! test-patts new-test-patts))
- (begin
- (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests")
- (set! required-tests (cons waiton required-tests))
- (set! test-patts new-test-patts))))
+ (if waiton-tconfig ;; BB: waiter should be in test-patts as well as the waiton have a tconfig.
+ (if waiton-itemized
+ (if waitors-in-testpatt
+ (begin
+ (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts)
+ (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
+ (set! required-tests (cons (conc waiton "/") required-tests))
+ (set! test-patts new-test-patts))
+ (begin
+ (debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it")
+ (set! tal (append (cons waiton tal)(list hed)))))
+ (begin
+ (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests")
+ (set! required-tests (cons waiton required-tests))
+ (set! test-patts new-test-patts)))
(begin
(debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it")
(set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests))
;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
@@ -538,10 +569,11 @@
;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
)))
(delete-duplicates (append waitons waitors)))
(let ((remtests (delete-duplicates (append waitons tal))))
+ (debug:print-info 8 *default-log-port* " remtests are "remtests)
(if (not (null? remtests))
(begin
;; (debug:print-info 0 *default-log-port* "Preprocessing continues for " (string-intersperse remtests ", "))
(loop (car remtests)(cdr remtests)))))))) ;; END test-names loop
@@ -603,25 +635,25 @@
;; but have items in reg; loop with (car reg)(cdr reg) '() reruns
;; If reg is empty => all done
(define (runs:queue-next-hed tal reg n regfull)
(if regfull
- (car reg)
+ (if (null? reg) #f (car reg))
(if (null? tal) ;; tal is used up, pop from reg
- (car reg)
+ (if (null? reg) #f (car reg))
(car tal))))
(define (runs:queue-next-tal tal reg n regfull)
(if regfull
tal
(if (null? tal) ;; must transfer from reg
- (cdr reg)
+ (if (null? reg) '() (cdr reg))
(cdr tal))))
(define (runs:queue-next-reg tal reg n regfull)
(if regfull
- (cdr reg)
+ (if (null? reg) '() (cdr reg)) ;; EXPLORE: reorder (cdr reg) such that looping is more efficient
(if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
'()
reg)))
;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216
@@ -630,13 +662,25 @@
(list (runs:queue-next-hed tal reg reglen regfull) ;; hed
(runs:queue-next-tal tal reg reglen regfull) ;; tal
(runs:queue-next-reg tal reg reglen regfull) ;; reg
reruns)) ;; reruns
+;; objective - iterate thru tests
+;; => want to prioritize tests we haven't seen before
+;; => sometimes need to squeeze things in (added to reg)
+;; => review of a previously seen test is higher priority of never visited test
+;; reg - list of previously visited tests
+;; tal - list of never visited tests
+;; prefer next hed to be from reg than tal.
+
(define runs:nothing-left-in-queue-count 0)
-;; BB: for future reference - suspect target vars are not expanded to env vars at this point (item expansion using [items]\nwhatever [system echo $TARGETVAR] doesnt work right whereas [system echo #{targetvar}] does.. Tal and Randy have tix on this. on first pass, var not set, on second pass, ok.
+;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
+;; (let loop ((hed (car sorted-test-names))
+;; (tal (cdr sorted-test-names))
+;; (reg '()) ;; registered, put these at the head of tal
+;; (reruns '()))
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
(let* ((loop-list (list hed tal reg reruns))
(prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
(if (list? res)
res
@@ -643,15 +687,26 @@
(begin
(debug:print 0 *default-log-port*
"ERROR: rmt:get-prereqs-not-met returned non-list!\n"
" res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
'()))))
+ (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(prereq-fails (runs:calc-prereq-fail prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
- (runnables (runs:calc-runnable prereqs-not-met)))
+ (runnables (runs:calc-runnable prereqs-not-met))
+ (unexpanded-prereqs
+ (filter (lambda (testname)
+ (let* ((test-rec (hash-table-ref test-records testname))
+ (items (tests:testqueue-get-items test-rec)))
+ ;;(BB> "HEY " testname "=>"items)
+ (or (procedure? items)(eq? items 'have-procedure))))
+ waitons))
+
+
+ )
(debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
"\n non-completed: " (runs:pretty-string non-completed)
@@ -666,13 +721,14 @@
(cond
;; all prereqs met, fire off the test
;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
- ((and (not (member 'toplevel testmode))
+ ((and (not (member 'toplevel testmode))
(member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
'(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-1")
(debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue")
(if (or (not (null? tal))
(not (null? reg)))
(runs:loop-values tal reg reglen regfull reruns)
(begin
@@ -685,14 +741,24 @@
(debug:print 0 *default-log-port* "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness")
(exit 0))
(set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1)))
#f)))
- ;;
- ((or (null? prereqs-not-met)
+ ;; desired result of below cond branch:
+ ;; we want to expand items in our test of interest (hed) in the following cases:
+ ;; case 1 - mode is itemmatch or itemwait:
+ ;; - all prereq tests have been expanded
+ ;; - at least one prereq's items have completed
+ ;; case 2 - mode is toplevel
+ ;; - prereqs are completed.
+ ;; - or no prereqs can complete
+ ;; case 3 - mode not specified
+ ;; - prereqs are completed and passed (we could consider removing "and passed" -- it would change behavior from current)
+ ((or (null? prereqs-not-met)
(and (member 'toplevel testmode)
(null? non-completed)))
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-2")
(debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
(let ((test-name (tests:testqueue-get-testname test-record)))
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
@@ -709,13 +775,14 @@
(list hed tal reg reruns))
(begin
(debug:print-error 0 *default-log-port* "The proc from reading the items table did not yield a list - please report this")
(exit 1))))))
- ((and (null? fails)
+ ((and (null? fails)
(null? prereq-fails)
(not (null? non-completed)))
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-3")
(let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x)))
(append newtal reruns)))
;; prereqstrs is a list of test names as strings that are prereqs for hed
(prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x)))
prereqs-not-met)))
@@ -740,22 +807,23 @@
(let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
(trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
(debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
(let ((test-id (rmt:get-test-id run-id hed "")))
- (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
+ (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
(if (and (null? trimmed-tal)
(null? trimmed-reg))
#f
(runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns)
))
(list (car newtal)(append (cdr newtal) reg) '() reruns))))
- ((and (null? fails) ;; have not-started tests, but unable to run them. everything looks completed with no prospect of unsticking something that is stuck. we should mark hed as moribund and exit or continue if there are more tests to consider
+ ((and (null? fails) ;; have not-started tests, but unable to run them. everything looks completed with no prospect of unsticking something that is stuck. we should mark hed as moribund and exit or continue if there are more tests to consider
(null? prereq-fails)
(null? non-completed))
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-4")
(if (runs:can-keep-running? hed 20)
(begin
(runs:inc-cant-run-tests hed)
(debug:print-info 0 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) ;;
;; getting here likely means the system is way overloaded, kill a full minute before continuing
@@ -768,37 +836,42 @@
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")))
(runs:loop-values tal reg reglen regfull reruns)
)))
- ((and
+ ((and
(or (not (null? fails))
(not (null? prereq-fails)))
(member 'normal testmode))
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-5")
(debug:print-info 1 *default-log-port* "test " hed " (mode=" testmode ") has failed prerequisite(s); "
(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
", removing it from to-do list")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id
(if (not (null? prereq-fails))
- (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
- (begin
- (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed)
- (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))))) ;; BB: this works, btu equivalent for itemwait mode does not work.
+ (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
+ (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))))
+ ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed)
+ ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work.
(if (or (not (null? reg))(not (null? tal)))
(begin
(hash-table-set! test-registry hed 'CANNOTRUN)
(runs:loop-values tal reg reglen regfull (cons hed reruns))
)
#f)) ;; #f flags do not loop
-
+
((and (not (null? fails))(member 'toplevel testmode))
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-6")
(if (or (not (null? reg))(not (null? tal)))
(list (car newtal)(append (cdr newtal) reg) '() reruns)
#f))
- ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over.
+ ((null? runnables)
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-7")
+ #f) ;; if we get here and non-completed is null then it is all over.
(else
+ (debug:print-info 4 *default-log-port* "cond branch - " "ei-8")
(debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")
(list (car newtal)(cdr newtal) reg reruns)))))
(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst)
(if (null? inlst)
@@ -859,11 +932,11 @@
(num-running-in-jobgroup(list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
- (fails (if (list? prereqs-not-met)
+ (fails (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs
(runs:calc-fails prereqs-not-met)
(begin
(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
'())))
(non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed!
@@ -1008,17 +1081,23 @@
(if (runs:lownoise "Waiting for more work to do..." 60)
(debug:print-info 0 *default-log-port* "Waiting for more work to do..."))
(thread-sleep! 1)
(list (car newtal)(cdr newtal) reg reruns))
;; the waiton is FAIL so no point in trying to run hed ever again
- (if (or (not (null? reg))(not (null? tal)))
- (if (or (vector? hed) (not (null? fails))) ;; BB: why do we need a vector? in my case, fails is populated (prereq failed), reg is not nul, and we really want to drop this one
+ (begin
+ (let ((my-test-id (rmt:get-test-id run-id test-name item-path)))
+ (mt:test-set-state-status-by-id run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2"))
+
+
+
+ (if (or (not (null? reg))(not (null? tal)))
+ (if (vector? hed)
(begin
(debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
" from the launch list as it has prerequistes that are FAIL")
(let ((test-id (rmt:get-test-id run-id hed "")))
- (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
+ (if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
(runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
;; This next is for the items
(if (not (null? fails))
@@ -1032,15 +1111,15 @@
(debug:print 2 *default-log-port* "nth-try("hed")="nth-try)
(cond
((member "RUNNING" (map db:test-get-state prereqs-not-met))
(if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
(debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
- (thread-sleep! 4)
+ (thread-sleep! 0.1)
(runs:loop-values tal reg reglen regfull reruns))
((or (not nth-try) ;; BB: condition on subsequent tries, condition below fires on first try
(and (number? nth-try)
- (< nth-try 10)))
+ (< nth-try 2)))
(hash-table-set! test-registry hed (if (number? nth-try)
(+ nth-try 1)
0))
(if (runs:lownoise (conc "not removing test " hed) 60)
(debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
@@ -1053,13 +1132,16 @@
#f ;; yes, really
(list (car tal)(cdr tal) reg reruns))
(begin
(if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry."))
- (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
- (hash-table-set! test-registry hed 0)
- (runs:loop-values newtal reg reglen regfull))))
+ ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
+ (mt:test-set-state-status-by-testname run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f)
+ (hash-table-set! test-registry hed 'removed) ;; was 0
+ (if (not (and (null? reg) (null? tal)))
+ (runs:loop-values tal reg reglen regfull reruns)
+ #f))))
(else
(if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met)
(hash-table-set! test-registry hed 'removed)
@@ -1068,15 +1150,20 @@
(rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
(list (if (null? tal)(car newtal)(car tal))
tal
reg
reruns)))))
- ;; can't drop this - maybe running? Just keep trying
- (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met?
- (if (null? runable-tests)
- #f ;; I think we are truly done here
- (runs:loop-values newtal reg reglen regfull reruns)))))))))
+ ;; ELSE: can't drop this - maybe running? Just keep trying
+
+ ;;(if (not (or (not (null? reg))(not (null? tal)))) ;; old experiment
+ (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met?
+ (if (null? runable-tests)
+ #f ;; I think we are truly done here
+ (runs:loop-values newtal reg reglen regfull reruns)))
+ ;;) ;;from old experiment
+ ) ;; end if (or (not (null? reg))(not (null? tal)))
+ ))))))
;; scan a list of tests looking to see if any are potentially runnable
;;
(define (runs:runable-tests tests)
(filter (lambda (t)
@@ -1175,11 +1262,11 @@
;; Do mark-and-find clean up of db before starting runing of quue
;;
;; (rmt:find-and-mark-incomplete)
- (let* ((run-info (rmt:get-run-info run-id))
+ (let* ((run-info (rmt:get-run-info run-id))
(tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path"))
(sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(test-registry (make-hash-table))
(registry-mutex (make-mutex))
(num-retries 0)
@@ -1230,14 +1317,16 @@
(hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st)))))
tests-info)
(set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
(let loop ((hed (car sorted-test-names))
- (tal (cdr sorted-test-names))
+ (tal (cdr sorted-test-names))
(reg '()) ;; registered, put these at the head of tal
(reruns '()))
+
+
(runs:incremental-print-results run-id)
(if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns))
;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
@@ -1321,23 +1410,24 @@
;; (loop (car tal)(cdr tal) reg reruns))))
(runs:incremental-print-results run-id)
(debug:print 4 *default-log-port* "TOP OF LOOP => "
"test-name: " test-name
- "\n test-record " test-record
"\n hed: " hed
- "\n itemdat: " itemdat
+ "\n tal: " tal
+ "\n reg: " reg
+ "\n test-record " test-record
+ "\n itemdat: " itemdat
"\n items: " items
"\n item-path: " item-path
"\n waitons: " waitons
"\n num-retries: " num-retries
- "\n tal: " tal
- "\n reruns: " reruns
+ "\n reruns: " reruns
"\n regfull: " regfull
"\n reglen: " reglen
"\n length reg: " (length reg)
- "\n reg: " reg)
+ )
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member test-name waitons)
(begin
@@ -1357,16 +1447,18 @@
(if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run
(not (member waiton reruns)))
1
#f))
waitons))))) ;; could do this more elegantly with a marker....
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-1")
(debug:print 0 *default-log-port* "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.")
(hash-table-set! test-registry tfullname 'removed))
;; items is #f then the test is ok to be handed off to launch (but not before)
;;
((not items)
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-2")
(debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
(not (null? tal)))
(loop (car tal)(cdr tal) reg reruns))
(runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
@@ -1376,10 +1468,11 @@
;; items processed into a list but not came in as a list been processed
;;
((and (list? items) ;; thus we know our items are already calculated
(not itemdat)) ;; and not yet expanded into the list of things to be done
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-3")
(debug:print-info 4 *default-log-port* "OUTER COND: (and (list? items)(not itemdat))")
;; Must determine if the items list is valid. Discard the test if it is not.
(if (and (list? items)
(> (length items) 0)
(and (list? (car items))
@@ -1391,26 +1484,37 @@
(string-intersperse varval "="))
row)
" ")
"\n"))
items)))
- (for-each
- (lambda (my-itemdat)
- (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
- (vector-copy! test-record newrec)
- newrec))
- (my-item-path (item-list->path my-itemdat)))
- (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here!
- (let ((newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path
- (tests:testqueue-set-items! new-test-record #f)
- (tests:testqueue-set-itemdat! new-test-record my-itemdat)
- (tests:testqueue-set-item_path! new-test-record my-item-path)
- (hash-table-set! test-records newtestname new-test-record)
- (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
- items)
-
- ;; (debug:print-info 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items")
+
+ (let* ((items-in-testpatt
+ (filter
+ (lambda (my-itemdat)
+ (tests:match test-patts hed (item-list->path my-itemdat) required: required-tests))
+ items) ))
+ (if (null? items-in-testpatt)
+ (let ((test-id (rmt:get-test-id run-id test-name "")))
+ (debug:print-info 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items matching test pattern -- marking status ZERO_ITEMS")
+ (if test-id
+ (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "This test has no items which match test pattern.")))
+
+ (for-each (lambda (my-itemdat)
+ (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
+ (vector-copy! test-record newrec)
+ newrec))
+ (my-item-path (item-list->path my-itemdat))
+
+ (newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path
+ (tests:testqueue-set-items! new-test-record #f)
+ (tests:testqueue-set-itemdat! new-test-record my-itemdat)
+ (tests:testqueue-set-item_path! new-test-record my-item-path)
+ (hash-table-set! test-records newtestname new-test-record)
+ (set! tal (append tal (list newtestname))))) ;; since these are itemized create new test names testname/itempath
+ items-in-testpatt)))
+
+
;; At this point we have possibly added items to tal but all must be handed off to
;; INNER COND logic. I think loop without rotating the queue
;; (loop hed tal reg reruns))
;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test
@@ -1420,25 +1524,31 @@
(loop (car tal)(cdr tal) reg reruns)))
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
;; EXPAND ITEMS
- ((or (procedure? items)(eq? items 'have-procedure)) ;; BB - target vars are env vars here? to allow expansion of [items]\nsomething [system echo $SOMETARGVAR], which is wonky
+ ((or (procedure? items)(eq? items 'have-procedure))
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-4")
(let ((can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
(if (and (list? can-run-more)
(car can-run-more))
- (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)))
+ (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here
(if loop-list
- (apply loop loop-list)))
+ (apply loop loop-list)
+ (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
+ )
+ )
;; if can't run more just loop with next possible test
(loop (car newtal)(cdr newtal) reg reruns))))
;; this case should not happen, added to help catch any bugs
((and (list? items) itemdat)
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-5")
(debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this")
(exit 1))
((not (null? reruns))
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-6")
(let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
(junked (lset-difference equal? tal newlst)))
(debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal)
(if (< num-retries max-retries)
(set! newlst (append reruns newlst)))
@@ -1446,15 +1556,18 @@
;; (thread-sleep! (+ 1 *global-delta*))
(if (not (null? newlst))
;; since reruns have been tacked on to newlst create new reruns from junked
(loop (car newlst)(cdr newlst) reg (delete-duplicates junked)))))
((not (null? tal))
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-7")
(debug:print-info 4 *default-log-port* "I'm pretty sure I shouldn't get here."))
((not (null? reg)) ;; could we get here with leftovers?
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-8")
(debug:print-info 0 *default-log-port* "Have leftovers!")
(loop (car reg)(cdr reg) '() reruns))
(else
+ (debug:print-info 4 *default-log-port* "cond branch - " "rtq-9")
(debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
))) ;; end loop on sorted test names
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
@@ -1484,16 +1597,16 @@
(debug:print-info 1 *default-log-port* "All tests launched")))
(define (runs:calc-fails prereqs-not-met)
(filter (lambda (test)
(and (vector? test) ;; not (string? test))
- (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED"))
+ (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...*
(not (member (db:test-get-status test)
'("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))))
prereqs-not-met))
-(define (runs:calc-prereq-fail prereqs-not-met)
+(define (runs:calc-prereq-fail prereqs-not-met) ;; REMOVEME since NOT_STARTED/PREQ_FAIL is now COMPLETED/PREQ_FAIL
(filter (lambda (test)
(and (vector? test) ;; not (string? test))
(equal? (db:test-get-state test) "NOT_STARTED")
(not (member (db:test-get-status test)
'("n/a" "KEEP_TRYING")))))
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -8,12 +8,12 @@
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp s11n)
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable
- )
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
+ directory-utils posix-extras matchable)
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(declare (unit server))
@@ -20,10 +20,11 @@
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses synchash))
(declare (uses http-transport))
+;;(declare (uses rpc-transport))
(declare (uses launch))
(declare (uses daemon))
(include "common_records.scm")
(include "db_records.scm")
@@ -32,10 +33,16 @@
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
+
+;;======================================================================
+;; P K T S S T U F F
+;;======================================================================
+
+;; ???
;;======================================================================
;; P K T S S T U F F
;;======================================================================
@@ -54,11 +61,11 @@
;;
(define (server:launch run-id transport-type)
(case transport-type
((http)(http-transport:launch))
;;((nmsg)(nmsg-transport:launch run-id))
- ((rpc) (rpc-transport:launch run-id))
+ ;;((rpc) (rpc-transport:launch run-id))
(else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -618,65 +618,180 @@
(case modifier
((none)(loop (conc (current-user-name) "_" area-name) 'user))
((user)(loop (conc (substring (common:get-area-path-signature) 0 4)
area-name) 'areasig))
(else #f)))))) ;; give up
+
+(define (task:print-runtime run-times saperator)
+(for-each
+ (lambda (run-time-info)
+ (let* ((run-name (vector-ref run-time-info 0))
+ (run-time (vector-ref run-time-info 1))
+ (target (vector-ref run-time-info 2)))
+ (print target saperator run-name saperator run-time )))
+ run-times))
+
+(define (task:print-runtime-as-json run-times)
+ (let loop ((run-time-info (car run-times))
+ (rema (cdr run-times))
+ (str ""))
+ (let* ((run-name (vector-ref run-time-info 0))
+ (run-time (vector-ref run-time-info 1))
+ (target (vector-ref run-time-info 2)))
+ ;(print (not (equal? str "")))
+ (if (not (equal? str ""))
+ (set! str (conc str ",")))
+ (if (null? rema)
+ (print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]")
+ (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}"))))))
+
+(define (task:get-run-times)
+ (let* (
+ (run-patt (if (args:get-arg "-run-patt")
+ (args:get-arg "-run-patt")
+ "%"))
+ (target-patt (if (args:get-arg "-target-patt")
+ (args:get-arg "-target-patt")
+ "%"))
+
+ (run-times (rmt:get-run-times run-patt target-patt )))
+ (if (eq? (length run-times) 0)
+ (begin
+ (print "Data not found!!")
+ (exit)))
+ (if (equal? (args:get-arg "-dumpmode") "json")
+ (task:print-runtime-as-json run-times)
+ (if (equal? (args:get-arg "-dumpmode") "csv")
+ (task:print-runtime run-times ",")
+ (task:print-runtime run-times " ")))))
+
+
+(define (task:print-testtime test-times saperator)
+(for-each
+ (lambda (test-time-info)
+ (let* ((test-name (vector-ref test-time-info 0))
+ (test-time (vector-ref test-time-info 2))
+ (test-item (if (eq? (string-length (vector-ref test-time-info 1)) 0)
+ "N/A"
+ (vector-ref test-time-info 1))))
+ (print test-name saperator test-item saperator test-time )))
+ test-times))
+
+(define (task:print-testtime-as-json test-times)
+ (let loop ((test-time-info (car test-times))
+ (rema (cdr test-times))
+ (str ""))
+ (let* ((test-name (vector-ref test-time-info 0))
+ (test-time (vector-ref test-time-info 2))
+ (item (vector-ref test-time-info 1)))
+ ;(print (not (equal? str "")))
+ (if (not (equal? str ""))
+ (set! str (conc str ",")))
+ (if (null? rema)
+ (print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]")
+ (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}"))))))
+
+
+ (define (task:get-test-times)
+ (let* ((runname (if (args:get-arg "-runname")
+ (args:get-arg "-runname")
+ #f))
+ (target (if (args:get-arg "-target")
+ (args:get-arg "-target")
+ #f))
+
+ (test-times (rmt:get-test-times runname target )))
+ (if (not runname)
+ (begin
+ (print "Error: Missing argument -runname")
+ (exit)))
+ (if (string-contains runname "%")
+ (begin
+ (print "Error: Invalid runname, '%' not allowed (" runname ") ")
+ (exit)))
+ (if (not target)
+ (begin
+ (print "Error: Missing argument -target")
+ (exit)))
+ (if (string-contains target "%")
+ (begin
+ (print "Error: Invalid target, '%' not allowed (" target ") ")
+ (exit)))
+
+ (if (eq? (length test-times) 0)
+ (begin
+ (print "Data not found!!")
+ (exit)))
+ (if (equal? (args:get-arg "-dumpmode") "json")
+ (task:print-testtime-as-json test-times)
+ (if (equal? (args:get-arg "-dumpmode") "csv")
+ (task:print-testtime test-times ",")
+ (task:print-testtime test-times " ")))))
+
+
;; gets mtpg-run-id and syncs the record if different
;;
(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
(let* ((runs-ht (hash-table-ref cached-info 'runs))
(runinf (hash-table-ref/default runs-ht run-id #f))
(area-id (vector-ref area-info 0)))
- (if runinf
+ (if runinf
runinf ;; already cached
(let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header >
(run-name (rmt:get-run-name-from-id run-id))
(row (db:get-rows run-dat)) ;; yes, this returns a single row
(header (db:get-header run-dat))
- (state (db:get-value-by-header row header "state "))
+ (state (db:get-value-by-header row header "state"))
(status (db:get-value-by-header row header "status"))
(owner (db:get-value-by-header row header "owner"))
(event-time (db:get-value-by-header row header "event_time"))
(comment (db:get-value-by-header row header "comment"))
(fail-count (db:get-value-by-header row header "fail_count"))
(pass-count (db:get-value-by-header row header "pass_count"))
(db-contour (db:get-value-by-header row header "contour"))
(contour (if (args:get-arg "-prepend-contour")
- (if (> (string-length db-contour) 0)
- db-contour
+ (if (and db-contour (not (equal? db-contour "")))
+ (begin
+ (print "db-contour")
+ db-contour)
(args:get-arg "-contour"))))
(keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
(conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
(target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
(conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu
(spec-id (pgdb:get-ttype dbh keytarg))
(new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id))
;; (area-id (db:get-value-by-header row header "area_id)"))
)
- (if new-run-id
+ (if new-run-id
(begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
(hash-table-set! runs-ht run-id new-run-id)
;; ensure key fields are up to date
(pgdb:refresh-run-info
dbh
new-run-id
state status owner event-time comment fail-count pass-count area-id)
new-run-id)
- (if (handle-exceptions
+ (if (equal? state "deleted")
+ (begin
+ (print "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
+ (if (handle-exceptions
exn
(begin (print-call-chain)
(print ((condition-property-accessor 'exn 'message) exn))
#f)
- (pgdb:insert-run
+
+ (pgdb:insert-run
dbh
spec-id target run-name state status owner event-time comment fail-count pass-count area-id))
(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
- #f))))))
+ #f)))))))
(define (tasks:sync-test-steps dbh cached-info test-step-ids)
+ (print "Sync Steps " test-step-ids )
(let ((test-ht (hash-table-ref cached-info 'tests))
(step-ht (hash-table-ref cached-info 'steps)))
(for-each
(lambda (test-step-id)
(let* ((test-step-info (rmt:get-steps-info-by-id test-step-id))
@@ -696,14 +811,14 @@
(begin
(if pgdb-test-id
(begin
(if pgdb-step-id
(begin
- (print "Updating existing test-step with test-id: " test-id " and step-id " step-id)
+ (print "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id )
(pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile))
(begin
- (print "Inserting test-step with test-id: " test-id " and step-id " step-id)
+ (print "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id)
(pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile )
(set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
(hash-table-set! step-ht step-id pgdb-step-id ))
(print "Error: Test not cashed")))
(print "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug
@@ -734,14 +849,14 @@
(begin
(if pgdb-test-id
(begin
(if pgdb-data-id
(begin
- (print "Updating existing test-data with test-id: " test-id " and data-id " data-id)
+ (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
(pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type))
(begin
- (print "Inserting test-data with test-id: " test-id " and data-id " data-id)
+ (print "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
(set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable))))
(hash-table-set! data-ht data-id pgdb-data-id ))
(begin
(print "Error: Test not in pgdb"))))
@@ -753,10 +868,11 @@
(define (tasks:sync-tests-data dbh cached-info test-ids area-info)
(let ((test-ht (hash-table-ref cached-info 'tests)))
(for-each
(lambda (test-id)
+ ;(print test-id)
(let* ((test-info (rmt:get-test-info-by-id #f test-id))
(run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm
(test-id (db:test-get-id test-info))
(test-name (db:test-get-testname test-info))
(item-path (db:test-get-item-path test-info))
@@ -784,14 +900,14 @@
;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived"
(if pgdb-run-id
(begin
(if pgdb-test-id ;; have a record
(begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
- (print "Updating existing test with run-id: " run-id " and test-id: " test-id)
+ (print "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id)
(pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived))
(begin
- (print "Inserting test with run-id: " run-id " and test-id: " test-id)
+ (print "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id)
(pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)
(set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
(hash-table-set! test-ht test-id pgdb-test-id))
(print "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
test-ids)))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -148,11 +148,11 @@
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
- (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs)))
+ (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
(let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
(exit 1))))
@@ -219,15 +219,26 @@
;; (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))))
- (string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
- (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
- patts-waiton)))
- ",")))
+ 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) ",")))
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
Index: utils/installall.sh
==================================================================
--- utils/installall.sh
+++ utils/installall.sh
@@ -37,12 +37,12 @@
echo
echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"
SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION
-CHICKEN_VERSION=4.12.0
-CHICKEN_BASEVER=4.12.0
+CHICKEN_VERSION=4.10.0
+CHICKEN_BASEVER=4.10.0
# Set up variables
#
case $SYSTEM_TYPE in
Ubuntu-17.04-x86_64-std)
@@ -68,94 +68,15 @@
IMVER=3.12
CHICKEN_VERSION=4.12.0
CHICKEN_BASEVER=4.12.0
;;
SUSE_LINUX_11-x86_64-std)
- KTYPE=26g4
+ KTYPE=26g4
CDVER=5.11.1
IUPVER=3.22
IMVER=3.12
- ;;
-CentOS_5.11-x86_64-std)
- KTYPE=24g3
- CDVER=5.4.1
- IUPVER=3.5
- IMVER=3.6.3
- ;;
-esac
-
-echo SYSTEM_TYPE=$SYSTEM_TYPE
-echo KTYPE=$KTYPE
-echo CDVER=$CDVER
-echo IUPVER=$IUPVER
-echo IMVER=$IMVER
-echo CHICKEN_VERSION=$CHICKEN_VERSION
-echo CHICKEN_BASEVER=$CHICKEN_BASEVER
-
-# NOTES:
-#
-# Centos with security setup may need to do commands such as following as root:
-#
-# NB// fix the paths first
-#
-# for a in /localdisk/chicken/4.8.0/lib/*.so;do chcon -t textrel_shlib_t $a; done
-
-echo ADDITIONAL_LIBPATH=$ADDITIONAL_LIBPATH
-echo
-echo To use previous IUP libraries set USEOLDIUP to yes
-echo USEOLDIUP=$USEOLDIUP
-echo
-echo Hit ^C now to do that
-
-# A nice way to run this script:
-#
-# script -c 'PREFIX=/tmp/delme ./installall.sh ' installall.log
-# logpro installall.logpro installall.html < installall.log
-# firefox installall.html
-
-sleep 5
-
-if [[ $proxy == "" ]]; then
- echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy'
- echo PROX=""
-else
- export http_proxy=http://$proxy
- export https_proxy=http://$proxy
- export PROX="-proxy $proxy"
-fi
-
-if [[ $KTYPE == "" ]]; then
- echo 'Using KTYPE=26'
- export KTYPE=26g4
-else
- echo Using KTYPE=$KTYPE
-fi
-
-# Put all the downloaded tar files in tgz
-mkdir -p tgz
-
-# http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz
-chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz
-if ! [[ -e tgz/$chicken_targz ]]; then
- wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz}
- mv $chicken_targz tgz
-fi
-
-BUILDHOME=$PWD
-DEPLOYTARG=$BUILDHOME/deploy
-
-if [[ $PREFIX == "" ]]; then
- PREFIX=$PWD/inst
-fi
-
-export PATH=$PREFIX/bin:$PATH
-export LIBPATH=$PREFIX/lib:$PREFIX/lib64:$ADDITIONAL_LIBPATH
-export LD_LIBRARY_PATH=$LIBPATH
-export CHICKEN_INSTALL=$PREFIX/bin/chicken-install
-mkdir -p $PREFIX
-echo "export PATH=$PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.sh
-echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.sh
+ >> $PREFIX/setup-chicken4x.sh
echo "export CHICKEN_DOC_PAGER=cat" >> $PREFIX/setup-chicken4x.sh
echo "setenv PATH $PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.csh
echo "setenv LD_LIBRARY_PATH $LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.csh
echo "setenv CHICKEN_DOC_PAGER cat" >> $PREFIX/setup-chicken4x.csh
ADDED utils/run2mock.scm
Index: utils/run2mock.scm
==================================================================
--- /dev/null
+++ utils/run2mock.scm
@@ -0,0 +1,169 @@
+#!/p/foundry/env/pkgs/chicken/4.10.1_v1.63/bin/csi -s
+; -*- Mode: Scheme; -*-
+
+
+(use ducttape-lib)
+(use posix-extras pathname-expand regex matchable)
+(use ini-file)
+;; plugs a hole in posix-extras in latter chicken versions
+(define ##sys#expand-home-path pathname-expand)
+(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+
+;; resolve fullpath to this script
+(define (get-this-script-fullpath #!key (argv (argv)))
+ (let* ((this-script
+ (cond
+ ((and (> (length argv) 2)
+ (string-match "^(.*/csi|csi)$" (car argv))
+ (string-match "^-(s|ss|sx|script)$" (cadr argv)))
+ (caddr argv))
+ (else (car argv))))
+ (fullpath (realpath this-script)))
+ fullpath))
+
+(define *this-script-fullpath* (get-this-script-fullpath))
+(define *this-script-dir* (pathname-directory *this-script-fullpath*))
+(define *this-script-name* (pathname-strip-directory *this-script-fullpath*))
+
+(define (false-on-exception thunk)
+ (handle-exceptions exn #f (thunk) ))
+
+(define (safe-file-exists? path-string)
+ (false-on-exception (lambda () (file-exists? path-string))))
+
+
+(define (crude-config-transformer infile outfile keep-sections-list append-text #!key (filter-patt #f))
+ (let* ((inlines (with-input-from-file infile read-lines))
+ (keep-lines (let loop ((lines-left inlines) (lines-out '()) (current-section #f) (section-lines-accumulator '()))
+ (let* ((this-line (if (not (null? lines-left))
+ (car lines-left)
+ ""))
+ (section-match (string-match "^\\s*\\[([^\\]]+)\\].*" this-line)))
+ (cond
+ ((null? lines-left)
+ (if (member current-section keep-sections-list)
+ (append lines-out (reverse section-lines-accumulator))
+ lines-out))
+ (section-match
+ (let* ((next-lines-left (cdr lines-left))
+ (next-lines-out (if (member current-section keep-sections-list)
+ (append lines-out (reverse section-lines-accumulator))
+ lines-out))
+ (next-current-section (cadr section-match))
+ (next-section-lines-accumulator (list this-line)))
+ (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator)))
+ (else
+ (let* ((next-lines-left (cdr lines-left))
+ (next-lines-out lines-out)
+ (next-current-section current-section)
+ (next-section-lines-accumulator
+ (cond
+ ((and filter-patt (string-match (conc "^.*"filter-patt".*$") this-line))
+ section-lines-accumulator)
+ (else (cons this-line section-lines-accumulator)))))
+ (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator))))))))
+ (with-output-to-file outfile (lambda ()
+ (print (string-join keep-lines "\n"))
+ (print)
+ (print append-text)
+ (print)))))
+
+
+(define (testconfig-transformer infile outfile)
+ (crude-config-transformer
+ infile
+ outfile
+ '("meta" "items" "requirements" "test_meta")
+
+ (conc "
+
+[ezsteps]
+alwayspass /bin/true
+
+")))
+
+
+
+
+
+(let* ((mtexe "/p/foundry/env/pkgs/megatest/1.64/31/bin/megatest")
+ (faux-mtra "/p/fdk/gwa/bjbarcla/issues/mtdev/ch/cap/faux")
+ (src-mtra "/nfs/pdx/disks/icf_fdk_asic_gwa002/asicfdkqa/fossil/megatestqa/afdkqa")
+ (target "p1275/5/ADF_r0.7_s/9p27t_tp0")
+ (run "ww38.4")
+ (src-mtdb (conc src-mtra "/megatest.db"))
+ (extra-src-testdirs '("/p/fdk/gwa/asicfdkqa/fossil/ext/afdkqa_ext/trunk/tests"))
+ (mtconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-config -target "target) read))
+ (runconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-runconfig -dumpmode sexp -target "target) read))
+ (testdir-alist (alist-ref "tests-paths" mtconf equal?))
+ (testdirs (filter safe-file-exists?
+ (append extra-src-testdirs
+ (list (conc src-mtra "/tests"))
+ (if (and testdir-alist (not (null? testdir-alist)))
+ (map cadr testdir-alist)
+ '()))))
+ (tconfigfiles
+ (apply append (map (lambda (src-testdir)
+ (with-input-from-pipe (conc "ls -1 "src-testdir"/*/testconfig") read-lines))
+ testdirs)))
+ (tconf-alist (filter identity
+ (map (lambda (tcfile)
+ (let* ((m (string-match "^.*/([^/]+)/testconfig$" tcfile)))
+ (if (not (null? m))
+ (cons (cadr m) tcfile)
+ #f)))
+ tconfigfiles))))
+
+; (pp mtconf)
+; (pp (list 'FOO testdir-alist)) (exit 1)
+ ;; make megatest area
+ (when (not (file-exists? src-mtdb))
+ (ierr "Source does not exist. Aborting. [src-mtdb]")
+ (exit 1))
+
+ (when (file-exists? faux-mtra)
+ (system (conc "cd "faux-mtra" && rm -rf $(/p/foundry/env/bin/mttmpdir)"))
+ (system (conc "rm -rf "faux-mtra)))
+
+ (system (conc "mkdir -p "faux-mtra))
+ (system (conc "mkdir -p "faux-mtra"/links"))
+ (system (conc "mkdir -p "faux-mtra"/disk0"))
+
+ (system (conc "cd "src-mtra" && "mtexe" -show-config -target "target" -dumpmode ini > "faux-mtra"/megatest.config.in"))
+ (crude-config-transformer
+ (conc faux-mtra"/megatest.config.in")
+ (conc faux-mtra"/megatest.config")
+ '("fields" "server" "env-override" "dashboard" "validvalues")
+ (conc "[setup]
+linktree "faux-mtra"/links
+max_concurrent_jobs 1000
+launch-delay 5
+use-wal 1
+
+" ;; emacs has trouble if a string has [ at the beginning of line, so breaking it up.
+"[disks]
+disk0 "faux-mtra"/disk0")
+ filter-patt: "MT_LINKTREE"
+ )
+
+
+ (system (conc "cd "src-mtra" && "mtexe" -show-runconfig -target "target" -dumpmode ini > "faux-mtra"/runconfigs.config"))
+
+
+ (system (conc "mkdir -p "faux-mtra"/tests"))
+
+ (for-each (lambda (tpair)
+ (pp tpair)
+ (let* ((testname (car tpair))
+ (src-tconfigfile (cdr tpair))
+ (destdir (conc faux-mtra"/tests/"testname)))
+ (do-or-die (conc "mkdir -p "destdir))
+ (do-or-die (conc "cp "src-tconfigfile" "destdir"/testconfig.in"))
+ (testconfig-transformer
+ (conc destdir"/testconfig.in")
+ (conc destdir"/testconfig"))
+ (print "processed test "testname)))
+ tconf-alist)
+
+
+ )