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 @@
-
+
The Megatest Users Manual