;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;;======================================================================
;; Megatestmod:
;;
;; Put things here don't fit anywhere else
;;======================================================================
(declare (unit megatestmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses processmod))
(declare (uses mtmod))
(declare (uses pkts))
(declare (uses servermod))
(use srfi-69)
(module megatestmod
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix base64 base64:)
(prefix sqlite3 sqlite3:)
data-structures
extras
files
pathname-expand
posix
posix-extras
(prefix dbi dbi:)
directory-utils
)
(use srfi-69))
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
system-information
)))
(import call-with-environment-variables
matchable
md5
message-digest
regex
regex-case
sparse-vectors
srfi-1
srfi-13
srfi-18
srfi-69
typed-records
z3
(prefix mtargs args:)
commonmod
configfmod
dbfile
dbmod
debugprint
mtmod
pkts
processmod
servermod
)
(define read-config (lambda ()(assert #f "FATAL: read-config proc not set!")))
(define (read-config-set! proc)
(set! read-config proc))
;;======================================================================
;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks #!key (configf #f))
(hash-table-ref/default
(or configf (read-config "megatest.config" #f #t))
"disks" '("none" "")))
(define (common:get-install-area)
(let ((exe-path (car (argv))))
(if (common:file-exists? exe-path)
(handle-exceptions
exn
#f
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
;;======================================================================
;; T A R G E T S , S T A T E , S T A T U S ,
;; R U N N A M E A N D T E S T P A T T
;;======================================================================
;;======================================================================
;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
;;
(define (common:get-runconfig-targets #!key (configf #f))
(let ((targs (sort (map car (hash-table->alist
(or configf ;; NOTE: There is no value in using runconfig:read here.
(read-config (conc *toppath* "/runconfigs.config")
#f #t)
(make-hash-table))))
string<?))
(target-patt (args:get-arg "-target")))
(if target-patt
(filter (lambda (x)
(patt-list-match x target-patt))
targs)
targs)))
(define (common:args-get-state)
(or (args:get-arg "-state")(args:get-arg ":state")))
(define (common:args-get-status)
(or (args:get-arg "-status")(args:get-arg ":status")))
(define (common:args-get-testpatt rconf)
(let* (;; (tagexpr (args:get-arg "-tagexpr"))
;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
(testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(cond
((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
(let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
(debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
patts-from-mode-patt)
(begin
(debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt)
#f))) ;; We do NOT fall back to "%"
;; (tags-testpatt
;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
;; tags-testpatt)
((and (equal? args-testpatt "%") rtestpatt)
(debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
rtestpatt)
(else
(debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
args-testpatt))))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
#f)
(if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
(conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
#f)
(let* ((tp (common:get-toppath #f))
(lt (conc tp "/lt")))
(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
lt)))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
(null? (filter string-null? tlist))))
#f)))
(if valid
(if split
tlist
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
(if exit-if-bad (exit 1))
#f)
#f))))
;;======================================================================
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
(if (getenv "MT_TEST_NAME")
(if (and (getenv "MT_ITEMPATH")
(not (equal? (getenv "MT_ITEMPATH") "")))
(getenv "MT_TEST_NAME")
(conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
#f))
;;======================================================================
;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
;;======================================================================
;; D A S H B O A R D U S E R V I E W S
;;======================================================================
;;======================================================================
;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
;;
(define (common:load-views-config)
(let* ((view-cfgdat (make-hash-table))
(home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config"))
(mthome-cfgfile (conc *toppath* "/.mtviews.config")))
(if (common:file-exists? mthome-cfgfile)
(read-config mthome-cfgfile view-cfgdat #t))
;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
(if (common:file-exists? home-cfgfile)
(read-config home-cfgfile view-cfgdat #t))
view-cfgdat))
;;======================================================================
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
(let ((res #t)) ;; priority by order of evaluation
(if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
(set! res #f)
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
(set! res #t))))
(if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
(if (getenv "MT_USE_CACHE")
(if (equal? (getenv "MT_USE_CACHE") "yes")
(set! res #t)
(if (equal? (getenv "MT_USE_CACHE") "no")
(set! res #f)))) ;; overrides -no-cache switch
res))
;;======================================================================
;; force use of server?
;;
(define (common:force-server?)
(let* ((force-setting (configf:lookup *configdat* "server" "force"))
(force-type (if force-setting (string->symbol force-setting) #f))
(force-result (case force-type
((#f) #f)
((always) #t)
((test) (if (args:get-arg "-execute") ;; we are in a test
#t
#f))
(else
(debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.")
#t)))) ;; default to requiring server
(if force-result
(begin
(debug:print-info 0 *default-log-port* "ATTENTION! Forcing use of server, force setting is \"" force-setting "\".")
#t)
#f)))
;; -mrw- this appears to not be used
;;
;; (define (common:print-delay-table)
;; (let loop ((x 0))
;; (print x "," (common:get-delay x 1))
;; (if (< x 2)
;; (loop (+ x 0.1)))))
;; (define (get-cpu-load #!key (remote-host #f))
;; (car (common:get-cpu-load remote-host)))
;;======================================================================
;; (let* ((load-res (process:cmd-run->list "uptime"))
;; (load-rx (regexp "load average:\\s+(\\d+)"))
;; (cpu-load #f))
;; (for-each (lambda (l)
;; (let ((match (string-search load-rx l)))
;; (if match
;; (let ((newval (string->number (cadr match))))
;; (if (number? newval)
;; (set! cpu-load newval))))))
;; (car load-res))
;; cpu-load))
;;======================================================================
;; given path get free space, allows override in [setup]
;; with free-space-script /path/to/some/script.sh
;;
(define (get-df path)
(if (configf:lookup *configdat* "setup" "free-space-script")
(with-input-from-pipe
(conc (configf:lookup *configdat* "setup" "free-space-script") " " path)
(lambda ()
(let ((res (read-line)))
(if (string? res)
(string->number res)))))
(get-unix-df path)))
(define (get-free-inodes path)
(if (configf:lookup *configdat* "setup" "free-inodes-script")
(with-input-from-pipe
(conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path)
(lambda ()
(let ((res (read-line)))
(if (string? res)
(string->number res)))))
(get-unix-inodes path)))
;;======================================================================
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
(let* ((required (string->number
;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks.
(or (configf:lookup *configdat* "setup" "dbdir-space-required")
"1000000")))
(dbdir (common:make-tmpdir-name *toppath* "")) ;; (db:get-dbdir))
(tdbspace (common:check-space-in-dir dbdir required))
(mdbspace (common:check-space-in-dir *toppath* required)))
(sort (list tdbspace mdbspace) (lambda (a b)
(< (cadr a)(cadr b))))))
;;======================================================================
;; check available space in dbdir, exit if insufficient
;;
(define (common:check-db-dir-and-exit-if-insufficient)
(let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now
(is-ok (car spacedat))
(dbspace (cadr spacedat))
(required (caddr spacedat))
(dbdir (cadddr spacedat)))
(if (not is-ok)
(begin
(debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
(exit 1)))))
;;======================================================================
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
(let* ((best #f)
(bestsize 0)
(default-min-inodes-string "1000000")
(default-min-inodes (string->number default-min-inodes-string))
(min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes)))
(for-each
(lambda (disk-num)
(let* ((dirpath (cadr (assoc disk-num disks)))
(freespc (cond
((not (directory? dirpath))
(if (common:low-noise-print 300 "disks not a dir " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
-1)
((not (file-write-access? dirpath))
(if (common:low-noise-print 300 "disks not writeable " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
-1)
((not (eq? (string-ref dirpath 0) #\/))
(if (common:low-noise-print 300 "disks not a proper path " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
-1)
(else
(get-df dirpath))))
(free-inodes (cond
((not (directory? dirpath))
(if (common:low-noise-print 300 "disks not a dir " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
-1)
((not (file-write-access? dirpath))
(if (common:low-noise-print 300 "disks not writeable " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
-1)
((not (eq? (string-ref dirpath 0) #\/))
(if (common:low-noise-print 300 "disks not a proper path " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
-1)
(else
(get-free-inodes dirpath))))
;;(free-inodes (get-free-inodes dirpath))
)
(debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes)
(if (and (> freespc bestsize)(> free-inodes min-inodes ))
(begin
(set! best (cons disk-num dirpath))
(set! bestsize freespc)))
;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes)
))
(map car disks))
(if (and best (> bestsize minsize))
best
#f))) ;; #f means no disk candidate found
(define (common:get-pkts-dirs mtconf use-lt)
(let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs")
(and use-lt
(conc (or *toppath*
(current-directory))
"/lt/.pkts"))))
(pktsdirs (if pktsdirs-str
(string-split pktsdirs-str " ")
#f)))
pktsdirs))
(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))
(pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir)))
(cond
((not (and pktsdir toppath pdbpath))
(debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.")
(debug:print 0 *default-log-port* " you need to have pktsdirs in the [setup] section."))
((not (common:file-exists? pktsdir))
(debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir))
((not (equal? (file-owner pktsdir)(current-effective-user-id)))
(debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
(else
(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 #!key (use-lt #f))
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(cond
((not (common:file-exists? pktsdir))
(debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist."))
((not (directory? pktsdir))
(debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory."))
((not (file-read-access? pktsdir))
(debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable."))
(else
(debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir)
(let ((pkts (glob (conc pktsdir "/*.pkt")))
(sqdb (dbi:db-conn pdb))
)
;; Put this in a transaction to avoid issues overloading the db
(sqlite3:with-transaction
sqdb
(lambda ()
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(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))
use-lt: use-lt))
;;======================================================================
;; D I S K S P A C E
;;======================================================================
(define (common:get-disk-space-used fpath)
(with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))
(define (get-unix-df path)
(let* ((df-results (process:cmd-run->list (conc "df " path)))
(space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
(freespc #f))
;; (write df-results)
(for-each (lambda (l)
(let ((match (string-search space-rx l)))
(if match
(let ((newval (string->number (cadr match))))
(if (number? newval)
(set! freespc newval))))))
(car df-results))
freespc))
(define (get-unix-inodes path)
(let* ((df-results (process:cmd-run->list (conc "df -i " path)))
(space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
(freenodes 0)) ;; 0 is a better failsafe than #f here.
;; (write df-results)
(for-each (lambda (l)
(let ((match (string-search space-rx l)))
(if match
(let ((newval (string->number (cadr match))))
(if (number? newval)
(set! freenodes newval))))))
(car df-results))
freenodes))
(define (common:check-space-in-dir dirpath required)
(let* ((dbspace (if (directory? dirpath)
(get-df dirpath)
0)))
(list (> dbspace required)
dbspace
required
dirpath)))
(define (get-uname . params)
(let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
(uname #f))
(if (null? (car uname-res))
"unknown"
(caar uname-res))))
;;======================================================================
;; 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 (not 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))))
(debug:print 0 *default-log-port* "pktsdir: "pktsdir)
(handle-exceptions
exn
(debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!!
(if (not (file-exists? pktsdir))
(create-directory pktsdir #t))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))))))))
;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
;;
(define (runconfigs-get config var)
(let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(if targ
(or (configf:lookup config targ var)
(configf:lookup config "default" var))
(configf:lookup config "default" var))))
;;======================================================================
;; R U N S
;;======================================================================
;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
;; (debug:print 0 *default-log-port* "QRY: " qry)
;; (db:delay-if-busy)
;;
;; NB// This call only operates on toplevel tests. Consider replacing it with more general call
;;
(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
(let ((test-ids '()))
(for-each
(lambda (testname)
(let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
(if currstate (conc "state='" currstate "' AND ") "")
(if currstatus (conc "status='" currstatus "' AND ") "")
" run_id=? AND testname LIKE ?;"))
(test-id (db:get-test-id dbstruct run-id testname "")))
(db:with-db
dbstruct
run-id
#t
(lambda (dbdat db)
(sqlite3:execute db qry
(or newstate currstate "NOT_STARTED")
(or newstatus currstate "UNKNOWN")
run-id testname)))
(if test-id
(begin
(set! test-ids (cons test-id test-ids))
(mt:process-triggers dbstruct run-id test-id newstate newstatus)))))
testnames)
test-ids))
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-subdb dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; (db:general-call dbdat 'set-test-start-time (list test-id)))
;; ;; (if msg
;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;; ;; process the test_data table
;; (if (and test-id state status (equal? status "AUTO"))
;; (db:test-data-rollup dbstruct run-id test-id status))
;; (mt:process-triggers dbstruct run-id test-id state status)))
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that as test-id instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
;; establish info on incoming test followed by info on top level test
;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
(let* ((testdat (if (number? test-name)
(db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
(db:keep-trying-until-true ;; in our threaded stuff this call could happen before the test is registered (maybe?)
db:get-test-info
(list dbstruct run-id test-name item-path)
10)))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
(db:test-get-testname testdat)
test-name))
(item-path (db:test-get-item-path testdat))
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (if tl-testdat
(db:test-get-id tl-testdat)
#f))
(new-state-eh #f)
(new-status-eh #f))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
(db:general-call dbstruct run-id 'set-test-start-time (list test-id)))
(mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct run-id #t
(lambda (dbdat db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
;; NB// Pass the db so it is part fo the transaction
(db:test-set-state-status-db 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 db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
(state-statuses (db:roll-up-rules state-status-counts state status))
(newstate (car state-statuses))
(newstatus (cadr state-statuses)))
(set! new-state-eh newstate)
(set! new-status-eh newstatus)
(debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: "
(apply conc
(map (lambda (x)
(conc
(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
state-status-counts))); end debug:print
(if tl-test-id
(db:test-set-state-status-db 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))
(if new-state-eh ;; moved from db:test-set-state-status
(mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh))
tr-res)))))
(define (mt:lazy-read-test-config test-name)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
(if tconf
tconf
(let ((test-dirs (tests:get-tests-search-path *configdat*)))
(let loop ((hed (car test-dirs))
(tal (cdr test-dirs)))
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (common:file-exists? tconfig-file)
(file-read-access? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
(if test-id
(let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id)))
(if test-dat
(let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; )
(test-name (db:test-get-testname test-dat))
(item-path (db:test-get-item-path test-dat))
(duration (db:test-get-run_duration test-dat))
(comment (db:test-get-comment test-dat))
(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)))
(target (getenv "MT_TARGET"))
(runname (getenv "MT_RUNNAME")))
;; (mutex-lock! *triggers-mutex*)
;;;;;; (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) ", exn=" 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))
;;;;;; (with-output-to-port *default-log-port*
;;;;;; (lambda ()
;;;;;; (print (condition->list exn))))
;;;;;; #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 target runname)))
;; 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 target runname)))))
(list
(conc state "/" status)
(conc state "/")
(conc "/" status)))
(pop-directory))
)) ;; )
;; (mutex-unlock! *triggers-mutex*)
)))))
;; Call this one to do all the work and get a standardized list of tests
;; gets paths from configs and finds valid tests
;; returns hash of testname --> fullpath
;;
(define (tests:get-all)
(let* ((test-search-path (tests:get-tests-search-path *configdat*)))
(debug:print 8 *default-log-port* "test-search-path: " test-search-path)
(tests:get-valid-tests (make-hash-table) test-search-path)))
(define (tests:get-tests-search-path cfgdat)
(let ((paths (let ((section (if cfgdat
(configf:get-section cfgdat "tests-paths")
#f)))
(if section
(map cadr section)
'()))))
(filter (lambda (d)
(if (directory-exists? d)
d
(begin
;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
;; (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
#f)))
(append paths (list (conc *toppath* "/tests"))))))
(define (tests:get-valid-tests test-registry tests-paths)
(if (null? tests-paths)
test-registry
(let loop ((hed (car tests-paths))
(tal (cdr tests-paths)))
(if (common:file-exists? hed)
(for-each (lambda (test-path)
(let* ((tname (last (string-split test-path "/")))
(tconfig (conc test-path "/testconfig")))
(if (and (not (hash-table-ref/default test-registry tname #f))
(common:file-exists? tconfig))
(hash-table-set! test-registry tname test-path))))
(glob (conc hed "/*"))))
(if (null? tal)
test-registry
(loop (car tal)(cdr tal))))))
(define (tests:filter-test-names-not-matched test-names test-patts)
(delete-duplicates
(filter (lambda (testname)
(not (tests:match test-patts testname #f)))
test-names)))
(define (tests:filter-test-names test-names test-patts)
(delete-duplicates
(filter (lambda (testname)
(tests:match test-patts testname #f))
test-names)))
;; itemmap is a list of testname patterns to maps
;; test1 .*/bar/(\d+) foo/\1
;; % foo/([^/]+) \1/bar
;;
;; # NOTE: the line with the single % could be the result of
;; # itemmap entry in requirements (legacy). The itemmap
;; # requirements entry is deprecated
;;
(define (tests:get-itemmaps tconfig)
(let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap"))
(itemmap-table (configf:get-section tconfig "itemmap")))
(append (if base-itemmap
(list (list "%" base-itemmap))
'())
(if itemmap-table
itemmap-table
'()))))
(define (tests:get-global-waitons rconfig)
(let* ((global-waitons (runconfigs-get rconfig "!GLOBAL_WAITONS")))
(if (string? global-waitons)
(string-split global-waitons)
'())))
;; return items given config
;;
(define (tests:get-items tconfig)
(let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
(itemstable (hash-table-ref/default tconfig "itemstable" #f)))
;; if either items or items table is a proc return it so test running
;; process can know to call items:get-items-from-config
;; if either is a list and none is a proc go ahead and call get-items
;; otherwise return #f - this is not an iterated test
(cond
((procedure? items)
(debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
items) ;; calc later
((procedure? itemstable)
(debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
itemstable) ;; calc later
((filter (lambda (x)
(let ((val (car x)))
(if (procedure? val) val #f)))
(append (if (list? items) items '())
(if (list? itemstable) itemstable '())))
'have-procedure)
((or (list? items)(list? itemstable)) ;; calc now
(debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
" items: " items " itemstable: " itemstable)
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
;;
;; genlib/testconfig sim/testconfig
;; genlib/sch sim/sch/cell1
;;
;; [requirements] [requirements]
;; mode itemwait
;; # trim off the cell to determine what to run for genlib
;; itemmap /.*
;;
;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '())
;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/"
;; expected -> "normal-first,normal-second/2,normal-second/"
;; testpatt = normal-second/2
;; waiting-test = normal-second
;; waiton-test = normal-first
;; itemmaps = ()
(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton)
(cond
(itemized-waiton
(let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test))
(patts (string-split test-patt ","))
(waiting-test-len (+ (string-length waiting-test) 1))
(patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test
(let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x))
(newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
;; (print "in map, x=" x ", newpatt=" newpatt)
newpatt))
(filter (lambda (x)
(eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
patts)))
(extended-test-patt (append patts (if (null? patts-waiton)
(list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
patts-waiton)))
(extended-test-patt-with-toplevels
(fold (lambda (testpatt-item accum )
(let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item)))
(cons testpatt-item
(if my-match
(cons
(conc (cadr my-match) "/")
accum)
accum))))
'()
extended-test-patt)))
(string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ",")))
(else ;; not waiting on items, waiting on entire waiton test.
(let* ((patts (string-split test-patt ","))
(new-patts (if (member waiton-test patts)
patts
(cons waiton-test patts))))
(string-intersperse (delete-duplicates new-patts) ",")))))
)