Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -29,11 +29,12 @@
configfmod.scm commonmod.scm dbmod.scm rmtmod.scm \
debugprint.scm mtver.scm csv-xml.scm servermod.scm \
hostinfo.scm adjutant.scm processmod.scm testsmod.scm \
itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm \
tasksmod.scm pgdb.scm launchmod.o runsmod.scm \
- http-transportmod.scm portloggermod.scm
+ http-transportmod.scm portloggermod.scm clientmod.scm \
+ archivemod.scm ezstepsmod.o
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
vg.scm
@@ -59,30 +60,35 @@
mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o
mofiles/servermod.o : mofiles/commonmod.o
mofiles/apimod.o : mofiles/servermod.o
-mofiles/mtmod.o : mofiles/debugprint.o
-mofiles/dbmod.o : mofiles/csv-xml.o mofiles/keysmod.o mofiles/mtmod.o
-
-mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o \
- mofiles/mtver.o mofiles/processmod.o \
- mofiles/configfmod.o mofiles/itemsmod.o mofiles/hostinfo.o
-
-mofiles/testmod.o : mofiles/rmtmod.o
-mofiles/rmtmod.o : mofiles/apimod.o
-mofiles/runsmod.o : mofiles/rmtmod.o
-
mofiles/apimod.o : mofiles/tasksmod.o
-mofiles/tasksmod.o : mofiles/pgdb.o mofiles/dbmod.o
-mofiles/rmtmod.o : mofiles/itemsmod.o
-
-mofiles/launchmod.o : mofiles/runsmod.o
-mofiles/servermod.o : mofiles/http-transportmod.o
+mofiles/archivemod.o : mofiles/launchmod.o
+mofiles/clientmod.o : mofiles/servermod.o
+mofiles/configfmod.o : mofiles/keysmod.o
+mofiles/commonmod.o : mofiles/configfmod.o
+mofiles/commonmod.o : mofiles/debugprint.o
+mofiles/commonmod.o : mofiles/hostinfo.o
+mofiles/commonmod.o : mofiles/itemsmod.o
+mofiles/commonmod.o : mofiles/mtargs.o
+mofiles/commonmod.o : mofiles/mtver.o
+mofiles/commonmod.o : mofiles/processmod.o
+mofiles/commonmod.o : mofiles/keysmod.o
+mofiles/dbmod.o : mofiles/csv-xml.o mofiles/keysmod.o mofiles/mtmod.o
mofiles/http-transportmod.o : mofiles/dbmod.o mofiles/portloggermod.o
-mofiles/testsmod.o : mofiles/itemsmod.o
+mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o
+mofiles/launchmod.o : mofiles/ezstepsmod.o
+mofiles/ezstepsmod.o : mofiles/rmtmod.o
+mofiles/mtmod.o : mofiles/debugprint.o
mofiles/portlogger.o : mofiles/tasksmod.o
+mofiles/rmtmod.o : mofiles/apimod.o
+mofiles/rmtmod.o : mofiles/itemsmod.o mofiles/clientmod.o
+mofiles/runsmod.o : mofiles/rmtmod.o mofiles/archivemod.o
+mofiles/servermod.o : mofiles/http-transportmod.o
+mofiles/tasksmod.o : mofiles/pgdb.o mofiles/dbmod.o
+mofiles/testsmod.o : mofiles/itemsmod.o mofiles/rmtmod.o mofiles/tasksmod.o
dashboard.o megatest.o : db_records.scm megatest-fossil-hash.scm
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
@@ -410,7 +416,7 @@
cd tests;make unit
DEPSFILES=*mod.scm adjutant.scm
deps.pdf : $(DEPSFILES)
- gendeps deps $(DEPSFILES)
+ gendeps deps.inc $(DEPSFILES)
dot deps.dot -Tpdf -o deps.pdf
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -14,622 +14,5 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-;;
-;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
-;;
-;; (declare (unit archive))
-;; (declare (uses db))
-;; (declare (uses common))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-;;
-;;======================================================================
-;;
-;;======================================================================
-
-;; NOT CURRENTLY USED
-;;
-;; (define (archive:main linktree target runname testname itempath options)
-;; (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempath))
-;; (flavor 'plain) ;; type of machine to run jobs on
-;; (maxload 1.5) ;; max allowed load for this work
-;; (adisks (archive:get-archive-disks)))
-;; ;; get testdir size
-;; ;; - hand off du to job mgr
-;; (if (and (common:file-exists? testdir)
-;; (file-writable? testdir))
-;; (let* ((dused (jobrunner:run-job
-;; flavor ;; machine type
-;; maxload ;; max allowed load
-;; '() ;; prevars - environment vars to set for the job
-;; common:get-disk-space-used ;; if a proc call it, if a string it is a unix command
-;; (list testdir)))
-;; (apath (archive:get-archive testname itempath dused)))
-;; (jobrunner:run-job
-;; flavor
-;; maxload
-;; '()
-;; archive:run-bup
-;; (list testdir apath))))))
-
-;; Get archive disks from megatest.config
-;;
-(define (archive:get-archive-disks)
- (let ((section (configf:get-section *configdat* "archive-disks")))
- (if section
- section
- '())))
-
-;; look for the best candidate archive area, else create new
-;; area
-;;
-(define (archive:get-archive testname itempath dused)
- ;; look up in archive_allocations if there is a pre-used archive
- ;; with adequate diskspace
- ;;
- (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
- (candidate-disks (map (lambda (block)
- (list
- (vector-ref block 1) ;; archive-area-name
- (vector-ref block 2))) ;; disk-path
- existing-blocks)))
- (or (common:get-disk-with-most-free-space candidate-disks dused)
- (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath))))
-
-;; allocate a new archive area
-;;
-(define (archive:allocate-new-archive-block blockid-cache run-area-home testsuite-name dneeded target run-name test-name)
- (let ((key (conc testsuite-name "/" target "/" run-name "/" test-name)))
- (if (hash-table-exists? blockid-cache key)
- (hash-table-ref blockid-cache key)
- (let* ((pscript (configf:lookup *configdat* "archive" "pathscript"))
- (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
- (apath (if pscript
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly. exn=" exn)
- (exit 1))
- (with-input-from-pipe
- pscript-cmd
- read-line))
- #f)) ;; this is the user-calculated archive path
- (adisks (archive:get-archive-disks))
- (best-disk (common:get-disk-with-most-free-space adisks dneeded)))
- (if best-disk
- (let* ((bdisk-name (car best-disk))
- (bdisk-path (cdr best-disk))
- (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5))
- (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
- (archive-name (if apath
- apath
- (let ((sec (current-seconds)))
- (conc (time->string (seconds->local-time sec) "%Y")
- "_q" (seconds->quarter sec) "/"
- testsuite-name "_" area-key))))
- (archive-path (conc bdisk-path "/" archive-name))
- (block-id (rmt:archive-register-block-name bdisk-id archive-path)))
- ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
- (if block-id ;; (and block-id allocation-id)
- (let ((res (cons block-id archive-path)))
- (hash-table-set! blockid-cache key res)
- res)
- (begin
- (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path)
- #f)))
- (begin
- (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name )
- #f)))))) ;; no best disk found
-
-;; archive - run bup
-;;
-;; 1. create the bup dir if not exists
-;; 2. start the du of each directory
-;; 3. gen index
-;; 4. save
-;;
-(define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex)
- ;; move the getting of archive space down into the below block so that a single run can
- ;; allocate as needed should a disk fill up
- ;;
- (let* ((blockid-cache (make-hash-table))
- (tsname (common:get-testsuite-name))
- (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
- (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
- (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area
- (disk-groups (make-hash-table)) ;;
- (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
- (test-dirs (make-hash-table))
- (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
- (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
- (if s (string->symbol s) 'bup)))
- (archiver-cmd (case archiver
- ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
- ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
- (else #f)))
- (src-archive-linktree (rmt:get-var "src-archive-linktree"))
- (print-prefix "Running: ") ;; change to #f to turn off printing
- (preclean-spec (configf:get-section *configdat* "archive-preclean")))
-
- (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))
- (rmt:set-var "src-archive-linktree" linktree))
- ;; (tests:match patt testname itempath)
-
- ;; from the test info bin the path to the test by stem
- ;;
- (for-each
- (lambda (test-dat)
- (let* ((item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- (mutex-lock! rp-mutex)
- (test-physical-path (if (common:file-exists? test-path)
- (common:real-path test-path)
- #f))
- (mutex-unlock! rp-mutex)
- (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f))
- (test-base (if (and partial-path-index
- test-physical-path )
- (substring test-physical-path
- 0
- partial-path-index)
- #f))
- ;; we need our archive dir checked for every test to enable folks who want to store other ways.
- (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
- (archive-dir (if archive-info (cdr archive-info) #f))
- (archive-id (if archive-info (car archive-info) -1)))
-
- (if (not archive-dir) ;; no archive disk found, this is fatal
- (begin
- (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least "
- min-space " MB space to the [archive-disks] section of megatest.config")
- (debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space")
- (debug:print 0 *default-log-port* " disks: "
- (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
- (exit 1))
- (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path))
-
- ;; preclean the test directory per the spec if provided
- (if (not (null? preclean-spec)) ;; we've been asked to preclean before archiving
- (let loop ((spec (car preclean-spec))
- (tail (cdr preclean-spec)))
- (if (> (length spec) 1)
- (let ((testspec (car spec))
- (rules (cadr spec)))
- (if (tests:match testspec test-name item-path)
- (begin
- (debug:print 0 *default-log-port* "INFO: cleanup requested for " test-physical-path)
- (common:dir-clean-up test-physical-path rules remove-empty: #t))
- (if (not (null? tail))
- (loop (car tail)(cdr tail)))))
- (begin
- (debug:print 0 *default-log-port* "ERROR: bad spec line in [archive-preclean] section. \"" spec "\"")
- (if (not (null? tail))(loop (car tail)(cdr tail)))))))
- (cond
- (toplevel/children
- (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id
- " as it is a toplevel test with children"))
- ((not (common:file-exists? test-path))
- (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path
- " as path " test-path " does not exist"))
- (else
- (debug:print 2 *default-log-port*
- "From test-dat=" test-dat " derived the following:\n"
- "test-partial-path = " test-partial-path "\n"
- "test-path = " test-path "\n"
- "test-physical-path = " test-physical-path "\n"
- "partial-path-index = " partial-path-index "\n"
- "test-base = " test-base)
- (hash-table-set! disk-groups test-base
- (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
- (hash-table-set! test-groups test-base
- (cons test-dat (hash-table-ref/default test-groups test-base '())))
- (hash-table-set! arch-groups test-base
- (cons archive-info (hash-table-ref/default arch-groups test-base '())))
- (hash-table-set! test-dirs test-id test-path)))))
- ;; test-path))))
- tests)
- (debug:print 0 *default-log-port* "INFO: DISK GROUPS=" (hash-table->alist disk-groups))
- ;; for each disk-group, initialize the bup area if needed
- (for-each
- (lambda (test-base)
- (let* ((disk-group (hash-table-ref disk-groups test-base))
- (arch-group (hash-table-ref arch-groups test-base))
- (arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
- (archive-id (car arch-info))
- (archive-dir (cdr arch-info)))
- (debug:print 0 *default-log-port* "Processing disk-group " test-base)
- (let* ((test-paths-in (hash-table-ref disk-groups test-base))
- (test-paths (if (args:get-arg "-include")
- (let ((subpaths (string-split (args:get-arg "-include") ",")))
- (apply append
- (map (lambda (p)
- (map (lambda (subp)
- (conc p "/" subp))
- subpaths))
- test-paths-in)))
- test-paths-in)))
- (if (not (common:file-exists? archive-dir))
- (create-directory archive-dir #t))
- (case archiver
- ((bup) ;; Archive using bup
- (let* ((bup-init-params (list "-d" archive-dir "init"))
- (bup-index-params (append (list "-d" archive-dir "index") test-paths))
- (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
- (conc "-" compress) ;; or (conc "--compress=" compress)
- "-n" (conc (common:get-testsuite-name) "-"(string-substitute "/" "-" target " "))
- (conc "--strip-path=" (conc test-base target "/" )) ;; if we push to the directory do we need this?
- )
- test-paths)))
- (if (not (common:file-exists? (conc archive-dir "/HEAD")))
- (begin
- ;; replace this with jobrunner stuff enventually
- (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
- ;; (mutex-lock! bup-mutex)
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
- (exit 1))))
- ;; (mutex-unlock! bup-mutex)
- ))
- (debug:print-info 2 *default-log-port* "Indexing data to be archived")
- ;; (mutex-lock! bup-mutex)
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
- (exit 1))))
- (debug:print-info 2 *default-log-port* "Archiving data with bup")
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an archiving data with bup. Archive failed.")
- (exit 1))))))
- ((7z tar)
- (for-each
- (lambda (test-dat)
- (let* ((test-id (db:test-get-id test-dat))
- (test-name (db:test-get-testname test-dat))
- (item-path (db:test-get-item-path test-dat))
- (test-full-name (db:test-make-full-name test-name item-path))
- (run-id (db:test-get-run_id test-dat))
- (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
- (run-name (rmt:get-run-name-from-id run-id))
- (source-dir (hash-table-ref test-dirs test-id)) ;; (conc test-base "/" test-name "/" item-path))
- (target-dir (string-substitute "/$" "" (conc archive-dir "/" target "/" run-name "/" test-full-name))))
- ;; create the test and item-path levels under archive-dir
- (create-directory (pathname-directory target-dir) #t)
- (run-n-wait
- (conc
- (string-substitute "ARCHIVE_NAME" target-dir archiver-cmd) " "
- "."
- )
- print-cmd: print-prefix
- run-dir: source-dir)))
- (hash-table-ref test-groups test-base))))
- ;; (mutex-unlock! bup-mutex)
- (for-each
- (lambda (test-dat)
- (let ((test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat)))
- (rmt:test-set-archive-block-id run-id test-id archive-id)
- (if (member (symbol->string archive-command) '("save-remove"))
- (begin
- (debug:print-info 0 *default-log-port* "remove testdat")
- (runs:remove-test-directory test-dat 'archive-remove)))))
- (hash-table-ref test-groups test-base)))))
- (hash-table-keys disk-groups))
- #t))
-
-(define (archive:megatest-db target-patt run-patt)
- (let* ((blockid-cache (make-hash-table))
- (tsname (common:get-testsuite-name))
- (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
- (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
- (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
- (if s (string->symbol s) 'bup)))
- (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))
- (print-prefix "Running: ")
- (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
- (archive-dir (if archive-info (cdr archive-info) #f))
- (archive-id (if archive-info (car archive-info) -1))
- (home-host (common:get-homehost))
- (archive-time (seconds->std-time-str (current-seconds)))
- (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
- (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
- (dbfile (conc archive-staging-db "/megatest.db")))
- (create-directory archive-staging-db #t)
- (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
- (if (eq? exit-code 0)
- (case archiver
- ((bup) ;; Archive using bup
- (let* ((bup-init-params (list "-d" archive-dir "init"))
- (bup-index-params (list "-d" archive-dir "index" archive-staging-db))
- (bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
- (conc "-" compress) ;; or (conc "--compress=" compress)
- "-n" (conc tsname "-megatest-db" )
- (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this?
- dbfile)))
- (if (not (common:file-exists? (conc archive-dir "/HEAD")))
- (begin
- ;; replace this with jobrunner stuff enventually
- (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
- (let-values (((pid-val exit-status exit-code)(run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
- (exit 1))))))
- (debug:print-info 2 *default-log-port* "Indexing data to be archived")
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
- (exit 1))))
- (debug:print-info 2 *default-log-port* "Archiving data with bup")
- (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
- (if (not (eq? exit-code 0))
- (begin
- (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.")
- (exit 1))
- (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp . Current timestamp: " (seconds->std-time-str (current-seconds)))))))
- (else
- (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
- (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))
-
-(define (archive:restore-db archive-path ts)
- (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
- (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
- (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
- (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
- (sleep 2)
- (db:multi-db-sync
- (db:setup #f)
- 'killservers
- ;'dejunk
- ;'adj-testids
- 'old2new
- )
- (debug:print-info 1 *default-log-port* "dropping triggers to update linktree")
- (rmt:drop-all-triggers)
- (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- (src-archive-linktree (rmt:get-var "src-archive-linktree")))
- (if (not (equal? src-archive-linktree linktree))
- (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
- (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")
- (rmt:create-all-triggers)
-))
-
-(define (archive:ls->list bup-exe archive-dir internal-path)
- (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort"))
- (res '()))
- (debug:print-info 0 *default-log-port* cmd)
- (handle-exceptions
- exn
- #f ;; anything goes wrong - assume the process in NOT running.
- (with-input-from-pipe
- cmd
- (lambda ()
- (let* ((inl (read-lines)))
- (reverse inl)))))))
-
-(define (time-string->seconds tstr ds-flag)
- (let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S")))
- (vector-set! atime 8 ds-flag)
- (local-time->seconds atime)))
-
-(define (seconds->std-time-str sec)
- (time->string
- (seconds->local-time sec)
- "%Y-%m-%d-%H%M%S"))
-
-
-(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update)
- (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update))
- (let* ((internal-path (conc testsuite-name "-" target))
- (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" )))
- (ts-list (archive:ls->list bup-exe archive-dir internal-path))
- (ds-flag (vector-ref (seconds->local-time) 8)))
- (let loop ((hed (car ts-list))
- (tail (cdr ts-list)))
- (if (and (null? tail) (equal? hed "latest"))
- #f
- (if (and (not (null? tail)) (equal? hed "latest"))
- (loop (car tail) (cdr tail))
- (let* ((archive-seconds (time-string->seconds hed ds-flag)))
- (if (< (abs (- archive-seconds test-last-update)) archive-update-delay)
- (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path))))
- (if (> (length test-list) 0)
- hed
- (if (not (null? tail))
- (loop (car tail) (cdr tail))
- #f)))
- (if (null? tail)
- #f
- (loop (car tail) (cdr tail))))))))))
-
-(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can
- ;; allocate as needed should a disk fill up
- ;;
- (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
-
- ;; from the test info bin the path to the test by stem
- ;;
- (for-each
- (lambda (test-dat)
- ;; When restoring test-dat will initially contain an old and invalid path to the test
- (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk.
- (item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
- (keyvals (rmt:get-key-val-pairs run-id))
- (target (string-intersperse (map cadr keyvals) "/"))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc run-name "/" (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory
- (mutex-lock! rp-mutex)
- (prev-test-physical-path (if (common:file-exists? test-path)
- ;; (read-symbolic-link test-path #t)
- (common:real-path test-path)
- #f))
- (mutex-unlock! rp-mutex)
- (new-test-physical-path (conc best-disk "/" test-partial-path))
- (archive-block-id (db:test-get-archived test-dat))
- (test-last-update (db:test-get-last_update test-dat))
- (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
- (archive-path (if (vector? archive-block-info)
- (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
- #f)) ;; no archive found?
- (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) (string-substitute "/" "-" target " ") test-partial-path test-last-update) #f))
- (archive-internal-path (conc (common:get-testsuite-name) "-" (string-substitute "/" "-" target " ") "/" archive-timestamp-dir "/" test-partial-path))
- (include-paths (args:get-arg "-include"))
- (exclude-pattern (args:get-arg "-exclude-rx"))
- (exclude-file (args:get-arg "-exclude-rx-from")))
- (if (not archive-timestamp-dir)
- (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
- (begin
- ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
- (debug:print-info 0 *default-log-port* "Archive time: " archive-timestamp-dir)
- (if (and (not toplevel/children) ;; special handling needed for toplevel with children
- prev-test-physical-path
- (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
- (let* ((base (pathname-directory prev-test-physical-path))
- (dirn (pathname-file prev-test-physical-path))
- (newn (conc base "/." dirn)))
- (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
- (rename-file prev-test-physical-path newn)))
-
- (if (and archive-path ;; no point in proceeding if there is no actual archive
- (not toplevel/children))
- (begin
- ;; CREATE WORK AREA
- ;; test-src-path == #f ==> don't copy in data from tests directory
- ;; itemdat == string ==> use directly
- (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
- ;; 1. Get the block id from the test info
- ;; 2. Get the block data given the block id
- ;; 3. Construct the paths etc. for the following command:
- ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
- ;; DO BUP RESTORE
- (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
- (new-test-path (if (vector? new-test-dat )
- (db:test-get-rundir new-test-dat)
- (begin
- (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
- (exit 1))))
- ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
- (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
- (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
- (debug:print-info 0 *default-log-port* bup-exe " " (string-join bup-restore-params " "))
- ;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
- ;; (mutex-unlock! bup-mutex)
- (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
- (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))))
- (filter vector? tests))))
-
-(define (common:get-youngest-test tests)
- (if (null? tests)
- #f
- (let ((res #f))
- (for-each
- (lambda (test-dat)
- (let ((event-time (db:test-get-event_time test-dat)))
- (if (or (not res)
- (> event-time (db:test-get-event_time res)))
- (set! res test-dat))))
- tests)
- res)))
-
-;; from an archive get a specific path - works ONLY with bup for now
-;;
-(define (archive:bup-get-data archive-command run-id-in run-name-in tests rp-mutex bup-mutex)
- (if (null? tests)
- (debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.")
-
- (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
- (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- ;; (test-dat (common:get-youngest-test tests))
- (destpath (args:get-arg "-dest")))
- (cond
- ((null? tests)
- (debug:print-error 0 *default-log-port*
- "No test matching provided target, runname pattern and test pattern found."))
- ((file-exists? destpath)
- (debug:print-error 0 *default-log-port*
- "Destination path alread exists! Please remove it before running get."))
- (else
- (let loop ((rem-tests tests))
- (let* ((test-dat (common:get-youngest-test rem-tests))
- (item-path (db:test-get-item-path test-dat))
- (test-name (db:test-get-testname test-dat))
- (test-id (db:test-get-id test-dat))
- (run-id (db:test-get-run_id test-dat))
- (run-name (rmt:get-run-name-from-id run-id))
- (keyvals (rmt:get-key-val-pairs run-id))
- (target (string-intersperse (map cadr keyvals) "/"))
-
- (toplevel/children (and (db:test-get-is-toplevel test-dat)
- (> (rmt:test-toplevel-num-items run-id test-name) 0)))
- (test-partial-path (conc target "/" run-name "/"
- (db:test-make-full-name test-name item-path)))
- ;; note the trailing slash to get the dir inspite of it being a link
- (test-path (conc linktree "/" test-partial-path))
- (archive-block-id (db:test-get-archived test-dat))
- (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
- (archive-path (if (vector? archive-block-info)
- (vector-ref archive-block-info 2)
- #f))
- (archive-internal-path (conc (common:get-testsuite-name) "-" run-id
- "/latest/" test-partial-path))
- (include-paths (args:get-arg "-include"))
- (exclude-pattern (args:get-arg "-exclude-rx"))
- (exclude-file (args:get-arg "-exclude-rx-from")))
-
- (if (and archive-path ;; no point in proceeding if there is no actual archive
- (not toplevel/children))
- (begin
- (let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data"))
- ;; " " ;; What is the empty string for?
- (if include-paths
- (map (lambda (p)
- (conc archive-internal-path "/" p))
- (string-split include-paths ","))
- (list archive-internal-path)))))
- (debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data")
- " from archive in " archive-path " ... " archive-internal-path)
- (run-n-wait bup-exe params: bup-restore-params print-cmd: #t)))
- (let ((new-rem-tests (filter (lambda (tdat)
- (or (not (eq? (db:test-get-id tdat) test-id))
- (not (eq? (db:test-get-run_id tdat) run-id))))
- rem-tests) ))
- (debug:print-info 0 *default-log-port*
- "No archive path in the record for run-id=" run-id
- " test-id=" test-id ", skipping.")
- (if (null? new-rem-tests)
- (begin
- (debug:print-info 0 *default-log-port* "No archives found for " target "/" run-name "...")
- #f)
- (loop new-rem-tests)))))))))))
-
ADDED archivemod.scm
Index: archivemod.scm
==================================================================
--- /dev/null
+++ archivemod.scm
@@ -0,0 +1,706 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit archivemod))
+(declare (uses debugprint))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses mtargs))
+(declare (uses mtver))
+;; (declare (uses csv-xml))
+;; (declare (uses keysmod))
+(declare (uses mtmod))
+(declare (uses dbmod))
+(declare (uses rmtmod))
+(declare (uses launchmod))
+(declare (uses processmod))
+
+(module archivemod
+ *
+
+(import scheme
+ (prefix sqlite3 sqlite3:)
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ (prefix base64 base64:)
+;; csv-xml
+ directory-utils
+ matchable
+ regex
+ s11n
+ srfi-1
+ srfi-13
+ srfi-18
+ srfi-69
+ stack
+ typed-records
+ z3
+ md5
+ message-digest
+
+ (prefix mtargs args:)
+ commonmod
+ configfmod
+ debugprint
+;; keysmod
+ mtmod
+ mtver
+ dbmod
+ rmtmod
+ launchmod
+ processmod
+
+ )
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+;;
+;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
+;;
+;; (declare (unit archive))
+;; (declare (uses db))
+;; (declare (uses common))
+;;
+;; (include "common_records.scm")
+(include "db_records.scm")
+;;
+;;======================================================================
+;;
+;;======================================================================
+
+;; NOT CURRENTLY USED
+;;
+;; (define (archive:main linktree target runname testname itempath options)
+;; (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempath))
+;; (flavor 'plain) ;; type of machine to run jobs on
+;; (maxload 1.5) ;; max allowed load for this work
+;; (adisks (archive:get-archive-disks)))
+;; ;; get testdir size
+;; ;; - hand off du to job mgr
+;; (if (and (common:file-exists? testdir)
+;; (file-writable? testdir))
+;; (let* ((dused (jobrunner:run-job
+;; flavor ;; machine type
+;; maxload ;; max allowed load
+;; '() ;; prevars - environment vars to set for the job
+;; common:get-disk-space-used ;; if a proc call it, if a string it is a unix command
+;; (list testdir)))
+;; (apath (archive:get-archive testname itempath dused)))
+;; (jobrunner:run-job
+;; flavor
+;; maxload
+;; '()
+;; archive:run-bup
+;; (list testdir apath))))))
+
+;; Get archive disks from megatest.config
+;;
+(define (archive:get-archive-disks)
+ (let ((section (configf:get-section *configdat* "archive-disks")))
+ (if section
+ section
+ '())))
+
+;; look for the best candidate archive area, else create new
+;; area
+;;
+(define (archive:get-archive testname itempath dused)
+ ;; look up in archive_allocations if there is a pre-used archive
+ ;; with adequate diskspace
+ ;;
+ (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
+ (candidate-disks (map (lambda (block)
+ (list
+ (vector-ref block 1) ;; archive-area-name
+ (vector-ref block 2))) ;; disk-path
+ existing-blocks)))
+ (or (common:get-disk-with-most-free-space candidate-disks dused)
+ (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath))))
+
+;; allocate a new archive area
+;;
+(define (archive:allocate-new-archive-block blockid-cache run-area-home testsuite-name dneeded target run-name test-name)
+ (let ((key (conc testsuite-name "/" target "/" run-name "/" test-name)))
+ (if (hash-table-exists? blockid-cache key)
+ (hash-table-ref blockid-cache key)
+ (let* ((pscript (configf:lookup *configdat* "archive" "pathscript"))
+ (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
+ (apath (if pscript
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly. exn=" exn)
+ (exit 1))
+ (with-input-from-pipe
+ pscript-cmd
+ read-line))
+ #f)) ;; this is the user-calculated archive path
+ (adisks (archive:get-archive-disks))
+ (best-disk (common:get-disk-with-most-free-space adisks dneeded)))
+ (if best-disk
+ (let* ((bdisk-name (car best-disk))
+ (bdisk-path (cdr best-disk))
+ (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5))
+ (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
+ (archive-name (if apath
+ apath
+ (let ((sec (current-seconds)))
+ (conc (time->string (seconds->local-time sec) "%Y")
+ "_q" (seconds->quarter sec) "/"
+ testsuite-name "_" area-key))))
+ (archive-path (conc bdisk-path "/" archive-name))
+ (block-id (rmt:archive-register-block-name bdisk-id archive-path)))
+ ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
+ (if block-id ;; (and block-id allocation-id)
+ (let ((res (cons block-id archive-path)))
+ (hash-table-set! blockid-cache key res)
+ res)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path)
+ #f)))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name )
+ #f)))))) ;; no best disk found
+
+;; archive - run bup
+;;
+;; 1. create the bup dir if not exists
+;; 2. start the du of each directory
+;; 3. gen index
+;; 4. save
+;;
+(define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex)
+ ;; move the getting of archive space down into the below block so that a single run can
+ ;; allocate as needed should a disk fill up
+ ;;
+ (let* ((blockid-cache (make-hash-table))
+ (tsname (common:get-testsuite-name))
+ (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
+ (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
+ (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area
+ (disk-groups (make-hash-table)) ;;
+ (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
+ (test-dirs (make-hash-table))
+ (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
+ (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
+ (if s (string->symbol s) 'bup)))
+ (archiver-cmd (case archiver
+ ((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
+ ((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
+ (else #f)))
+ (src-archive-linktree (rmt:get-var "src-archive-linktree"))
+ (print-prefix "Running: ") ;; change to #f to turn off printing
+ (preclean-spec (configf:get-section *configdat* "archive-preclean")))
+
+ (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))
+ (rmt:set-var "src-archive-linktree" linktree))
+ ;; (tests:match patt testname itempath)
+
+ ;; from the test info bin the path to the test by stem
+ ;;
+ (for-each
+ (lambda (test-dat)
+ (let* ((item-path (db:test-get-item-path test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat))
+
+ (toplevel/children (and (db:test-get-is-toplevel test-dat)
+ (> (rmt:test-toplevel-num-items run-id test-name) 0)))
+ (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
+ ;; note the trailing slash to get the dir inspite of it being a link
+ (test-path (conc linktree "/" test-partial-path))
+ (mutex-lock! rp-mutex)
+ (test-physical-path (if (common:file-exists? test-path)
+ (common:real-path test-path)
+ #f))
+ (mutex-unlock! rp-mutex)
+ (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f))
+ (test-base (if (and partial-path-index
+ test-physical-path )
+ (substring test-physical-path
+ 0
+ partial-path-index)
+ #f))
+ ;; we need our archive dir checked for every test to enable folks who want to store other ways.
+ (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
+ (archive-dir (if archive-info (cdr archive-info) #f))
+ (archive-id (if archive-info (car archive-info) -1)))
+
+ (if (not archive-dir) ;; no archive disk found, this is fatal
+ (begin
+ (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least "
+ min-space " MB space to the [archive-disks] section of megatest.config")
+ (debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space")
+ (debug:print 0 *default-log-port* " disks: "
+ (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
+ (exit 1))
+ (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving test " test-path))
+
+ ;; preclean the test directory per the spec if provided
+ (if (not (null? preclean-spec)) ;; we've been asked to preclean before archiving
+ (let loop ((spec (car preclean-spec))
+ (tail (cdr preclean-spec)))
+ (if (> (length spec) 1)
+ (let ((testspec (car spec))
+ (rules (cadr spec)))
+ (if (tests:match testspec test-name item-path)
+ (begin
+ (debug:print 0 *default-log-port* "INFO: cleanup requested for " test-physical-path)
+ (common:dir-clean-up test-physical-path rules remove-empty: #t))
+ (if (not (null? tail))
+ (loop (car tail)(cdr tail)))))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: bad spec line in [archive-preclean] section. \"" spec "\"")
+ (if (not (null? tail))(loop (car tail)(cdr tail)))))))
+ (cond
+ (toplevel/children
+ (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id
+ " as it is a toplevel test with children"))
+ ((not (common:file-exists? test-path))
+ (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path
+ " as path " test-path " does not exist"))
+ (else
+ (debug:print 2 *default-log-port*
+ "From test-dat=" test-dat " derived the following:\n"
+ "test-partial-path = " test-partial-path "\n"
+ "test-path = " test-path "\n"
+ "test-physical-path = " test-physical-path "\n"
+ "partial-path-index = " partial-path-index "\n"
+ "test-base = " test-base)
+ (hash-table-set! disk-groups test-base
+ (cons test-physical-path (hash-table-ref/default disk-groups test-base '())))
+ (hash-table-set! test-groups test-base
+ (cons test-dat (hash-table-ref/default test-groups test-base '())))
+ (hash-table-set! arch-groups test-base
+ (cons archive-info (hash-table-ref/default arch-groups test-base '())))
+ (hash-table-set! test-dirs test-id test-path)))))
+ ;; test-path))))
+ tests)
+ (debug:print 0 *default-log-port* "INFO: DISK GROUPS=" (hash-table->alist disk-groups))
+ ;; for each disk-group, initialize the bup area if needed
+ (for-each
+ (lambda (test-base)
+ (let* ((disk-group (hash-table-ref disk-groups test-base))
+ (arch-group (hash-table-ref arch-groups test-base))
+ (arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
+ (archive-id (car arch-info))
+ (archive-dir (cdr arch-info)))
+ (debug:print 0 *default-log-port* "Processing disk-group " test-base)
+ (let* ((test-paths-in (hash-table-ref disk-groups test-base))
+ (test-paths (if (args:get-arg "-include")
+ (let ((subpaths (string-split (args:get-arg "-include") ",")))
+ (apply append
+ (map (lambda (p)
+ (map (lambda (subp)
+ (conc p "/" subp))
+ subpaths))
+ test-paths-in)))
+ test-paths-in)))
+ (if (not (common:file-exists? archive-dir))
+ (create-directory archive-dir #t))
+ (case archiver
+ ((bup) ;; Archive using bup
+ (let* ((bup-init-params (list "-d" archive-dir "init"))
+ (bup-index-params (append (list "-d" archive-dir "index") test-paths))
+ (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
+ (conc "-" compress) ;; or (conc "--compress=" compress)
+ "-n" (conc (common:get-testsuite-name) "-"(string-substitute "/" "-" target " "))
+ (conc "--strip-path=" (conc test-base target "/" )) ;; if we push to the directory do we need this?
+ )
+ test-paths)))
+ (if (not (common:file-exists? (conc archive-dir "/HEAD")))
+ (begin
+ ;; replace this with jobrunner stuff enventually
+ (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
+ ;; (mutex-lock! bup-mutex)
+ (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
+ (if (not (eq? exit-code 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
+ (exit 1))))
+ ;; (mutex-unlock! bup-mutex)
+ ))
+ (debug:print-info 2 *default-log-port* "Indexing data to be archived")
+ ;; (mutex-lock! bup-mutex)
+ (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
+ (if (not (eq? exit-code 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
+ (exit 1))))
+ (debug:print-info 2 *default-log-port* "Archiving data with bup")
+ (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ (if (not (eq? exit-code 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "There was an archiving data with bup. Archive failed.")
+ (exit 1))))))
+ ((7z tar)
+ (for-each
+ (lambda (test-dat)
+ (let* ((test-id (db:test-get-id test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (item-path (db:test-get-item-path test-dat))
+ (test-full-name (db:test-make-full-name test-name item-path))
+ (run-id (db:test-get-run_id test-dat))
+ (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
+ (run-name (rmt:get-run-name-from-id run-id))
+ (source-dir (hash-table-ref test-dirs test-id)) ;; (conc test-base "/" test-name "/" item-path))
+ (target-dir (string-substitute "/$" "" (conc archive-dir "/" target "/" run-name "/" test-full-name))))
+ ;; create the test and item-path levels under archive-dir
+ (create-directory (pathname-directory target-dir) #t)
+ (run-n-wait
+ (conc
+ (string-substitute "ARCHIVE_NAME" target-dir archiver-cmd) " "
+ "."
+ )
+ print-cmd: print-prefix
+ run-dir: source-dir)))
+ (hash-table-ref test-groups test-base))))
+ ;; (mutex-unlock! bup-mutex)
+ (for-each
+ (lambda (test-dat)
+ (let ((test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat)))
+ (rmt:test-set-archive-block-id run-id test-id archive-id)
+ (if (member (symbol->string archive-command) '("save-remove"))
+ (begin
+ (debug:print-info 0 *default-log-port* "remove testdat")
+ (runs:remove-test-directory test-dat 'archive-remove)))))
+ (hash-table-ref test-groups test-base)))))
+ (hash-table-keys disk-groups))
+ #t))
+
+(define (archive:megatest-db target-patt run-patt)
+ (let* ((blockid-cache (make-hash-table))
+ (tsname (common:get-testsuite-name))
+ (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
+ (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
+ (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
+ (if s (string->symbol s) 'bup)))
+ (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))
+ (print-prefix "Running: ")
+ (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
+ (archive-dir (if archive-info (cdr archive-info) #f))
+ (archive-id (if archive-info (car archive-info) -1))
+ (home-host (common:get-homehost))
+ (archive-time (seconds->std-time-str (current-seconds)))
+ (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
+ (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
+ (dbfile (conc archive-staging-db "/megatest.db")))
+ (create-directory archive-staging-db #t)
+ (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
+ (if (eq? exit-code 0)
+ (case archiver
+ ((bup) ;; Archive using bup
+ (let* ((bup-init-params (list "-d" archive-dir "init"))
+ (bup-index-params (list "-d" archive-dir "index" archive-staging-db))
+ (bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
+ (conc "-" compress) ;; or (conc "--compress=" compress)
+ "-n" (conc tsname "-megatest-db" )
+ (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this?
+ dbfile)))
+ (if (not (common:file-exists? (conc archive-dir "/HEAD")))
+ (begin
+ ;; replace this with jobrunner stuff enventually
+ (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
+ (let-values (((pid-val exit-status exit-code)(run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
+ (if (not (eq? exit-code 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
+ (exit 1))))))
+ (debug:print-info 2 *default-log-port* "Indexing data to be archived")
+ (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
+ (if (not (eq? exit-code 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
+ (exit 1))))
+ (debug:print-info 2 *default-log-port* "Archiving data with bup")
+ (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ (if (not (eq? exit-code 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.")
+ (exit 1))
+ (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp . Current timestamp: " (seconds->std-time-str (current-seconds)))))))
+ (else
+ (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
+ (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))
+
+(define (archive:restore-db archive-path ts)
+ (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
+ (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
+ (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
+ (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
+ (sleep 2)
+ (db:multi-db-sync
+ (db:setup #f)
+ 'killservers
+ ;'dejunk
+ ;'adj-testids
+ 'old2new
+ )
+ (debug:print-info 1 *default-log-port* "dropping triggers to update linktree")
+ (rmt:drop-all-triggers)
+ (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (src-archive-linktree (rmt:get-var "src-archive-linktree")))
+ (if (not (equal? src-archive-linktree linktree))
+ (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
+ (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")
+ (rmt:create-all-triggers)
+))
+
+(define (archive:ls->list bup-exe archive-dir internal-path)
+ (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort"))
+ (res '()))
+ (debug:print-info 0 *default-log-port* cmd)
+ (handle-exceptions
+ exn
+ #f ;; anything goes wrong - assume the process in NOT running.
+ (with-input-from-pipe
+ cmd
+ (lambda ()
+ (let* ((inl (read-lines)))
+ (reverse inl)))))))
+
+(define (time-string->seconds tstr ds-flag)
+ (let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S")))
+ (vector-set! atime 8 ds-flag)
+ (local-time->seconds atime)))
+
+(define (seconds->std-time-str sec)
+ (time->string
+ (seconds->local-time sec)
+ "%Y-%m-%d-%H%M%S"))
+
+
+(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update)
+ (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update))
+ (let* ((internal-path (conc testsuite-name "-" target))
+ (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" )))
+ (ts-list (archive:ls->list bup-exe archive-dir internal-path))
+ (ds-flag (vector-ref (seconds->local-time) 8)))
+ (let loop ((hed (car ts-list))
+ (tail (cdr ts-list)))
+ (if (and (null? tail) (equal? hed "latest"))
+ #f
+ (if (and (not (null? tail)) (equal? hed "latest"))
+ (loop (car tail) (cdr tail))
+ (let* ((archive-seconds (time-string->seconds hed ds-flag)))
+ (if (< (abs (- archive-seconds test-last-update)) archive-update-delay)
+ (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path))))
+ (if (> (length test-list) 0)
+ hed
+ (if (not (null? tail))
+ (loop (car tail) (cdr tail))
+ #f)))
+ (if (null? tail)
+ #f
+ (loop (car tail) (cdr tail))))))))))
+
+(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can
+ ;; allocate as needed should a disk fill up
+ ;;
+ (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
+
+ ;; from the test info bin the path to the test by stem
+ ;;
+ (for-each
+ (lambda (test-dat)
+ ;; When restoring test-dat will initially contain an old and invalid path to the test
+ (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk.
+ (item-path (db:test-get-item-path test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat))
+ (keyvals (rmt:get-key-val-pairs run-id))
+ (target (string-intersperse (map cadr keyvals) "/"))
+
+ (toplevel/children (and (db:test-get-is-toplevel test-dat)
+ (> (rmt:test-toplevel-num-items run-id test-name) 0)))
+ (test-partial-path (conc run-name "/" (db:test-make-full-name test-name item-path)))
+ ;; note the trailing slash to get the dir inspite of it being a link
+ (test-path (conc linktree "/" test-partial-path))
+ ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory
+ (mutex-lock! rp-mutex)
+ (prev-test-physical-path (if (common:file-exists? test-path)
+ ;; (read-symbolic-link test-path #t)
+ (common:real-path test-path)
+ #f))
+ (mutex-unlock! rp-mutex)
+ (new-test-physical-path (conc best-disk "/" test-partial-path))
+ (archive-block-id (db:test-get-archived test-dat))
+ (test-last-update (db:test-get-last_update test-dat))
+ (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
+ (archive-path (if (vector? archive-block-info)
+ (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
+ #f)) ;; no archive found?
+ (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) (string-substitute "/" "-" target " ") test-partial-path test-last-update) #f))
+ (archive-internal-path (conc (common:get-testsuite-name) "-" (string-substitute "/" "-" target " ") "/" archive-timestamp-dir "/" test-partial-path))
+ (include-paths (args:get-arg "-include"))
+ (exclude-pattern (args:get-arg "-exclude-rx"))
+ (exclude-file (args:get-arg "-exclude-rx-from")))
+ (if (not archive-timestamp-dir)
+ (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
+ (begin
+ ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
+ (debug:print-info 0 *default-log-port* "Archive time: " archive-timestamp-dir)
+ (if (and (not toplevel/children) ;; special handling needed for toplevel with children
+ prev-test-physical-path
+ (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
+ (let* ((base (pathname-directory prev-test-physical-path))
+ (dirn (pathname-file prev-test-physical-path))
+ (newn (conc base "/." dirn)))
+ (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
+ (rename-file prev-test-physical-path newn)))
+
+ (if (and archive-path ;; no point in proceeding if there is no actual archive
+ (not toplevel/children))
+ (begin
+ ;; CREATE WORK AREA
+ ;; test-src-path == #f ==> don't copy in data from tests directory
+ ;; itemdat == string ==> use directly
+ (create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
+ ;; 1. Get the block id from the test info
+ ;; 2. Get the block data given the block id
+ ;; 3. Construct the paths etc. for the following command:
+ ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
+ ;; DO BUP RESTORE
+ (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
+ (new-test-path (if (vector? new-test-dat )
+ (db:test-get-rundir new-test-dat)
+ (begin
+ (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
+ (exit 1))))
+ ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
+ (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
+ (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
+ (debug:print-info 0 *default-log-port* bup-exe " " (string-join bup-restore-params " "))
+ ;; (mutex-lock! bup-mutex)
+ (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
+ ;; (mutex-unlock! bup-mutex)
+ (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
+ (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))))
+ (filter vector? tests))))
+
+(define (common:get-youngest-test tests)
+ (if (null? tests)
+ #f
+ (let ((res #f))
+ (for-each
+ (lambda (test-dat)
+ (let ((event-time (db:test-get-event_time test-dat)))
+ (if (or (not res)
+ (> event-time (db:test-get-event_time res)))
+ (set! res test-dat))))
+ tests)
+ res)))
+
+;; from an archive get a specific path - works ONLY with bup for now
+;;
+(define (archive:bup-get-data archive-command run-id-in run-name-in tests rp-mutex bup-mutex)
+ (if (null? tests)
+ (debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.")
+
+ (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
+ ;; (test-dat (common:get-youngest-test tests))
+ (destpath (args:get-arg "-dest")))
+ (cond
+ ((null? tests)
+ (debug:print-error 0 *default-log-port*
+ "No test matching provided target, runname pattern and test pattern found."))
+ ((file-exists? destpath)
+ (debug:print-error 0 *default-log-port*
+ "Destination path alread exists! Please remove it before running get."))
+ (else
+ (let loop ((rem-tests tests))
+ (let* ((test-dat (common:get-youngest-test rem-tests))
+ (item-path (db:test-get-item-path test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat))
+ (run-name (rmt:get-run-name-from-id run-id))
+ (keyvals (rmt:get-key-val-pairs run-id))
+ (target (string-intersperse (map cadr keyvals) "/"))
+
+ (toplevel/children (and (db:test-get-is-toplevel test-dat)
+ (> (rmt:test-toplevel-num-items run-id test-name) 0)))
+ (test-partial-path (conc target "/" run-name "/"
+ (db:test-make-full-name test-name item-path)))
+ ;; note the trailing slash to get the dir inspite of it being a link
+ (test-path (conc linktree "/" test-partial-path))
+ (archive-block-id (db:test-get-archived test-dat))
+ (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
+ (archive-path (if (vector? archive-block-info)
+ (vector-ref archive-block-info 2)
+ #f))
+ (archive-internal-path (conc (common:get-testsuite-name) "-" run-id
+ "/latest/" test-partial-path))
+ (include-paths (args:get-arg "-include"))
+ (exclude-pattern (args:get-arg "-exclude-rx"))
+ (exclude-file (args:get-arg "-exclude-rx-from")))
+
+ (if (and archive-path ;; no point in proceeding if there is no actual archive
+ (not toplevel/children))
+ (begin
+ (let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data"))
+ ;; " " ;; What is the empty string for?
+ (if include-paths
+ (map (lambda (p)
+ (conc archive-internal-path "/" p))
+ (string-split include-paths ","))
+ (list archive-internal-path)))))
+ (debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data")
+ " from archive in " archive-path " ... " archive-internal-path)
+ (run-n-wait bup-exe params: bup-restore-params print-cmd: #t)))
+ (let ((new-rem-tests (filter (lambda (tdat)
+ (or (not (eq? (db:test-get-id tdat) test-id))
+ (not (eq? (db:test-get-run_id tdat) run-id))))
+ rem-tests) ))
+ (debug:print-info 0 *default-log-port*
+ "No archive path in the record for run-id=" run-id
+ " test-id=" test-id ", skipping.")
+ (if (null? new-rem-tests)
+ (begin
+ (debug:print-info 0 *default-log-port* "No archives found for " target "/" run-name "...")
+ #f)
+ (loop new-rem-tests)))))))))))
+
+
+
+)
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -14,117 +14,5 @@
;; 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 .
-;;======================================================================
-;; C L I E N T S
-;;======================================================================
-
-;; (use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
-;; message-digest matchable spiffy uri-common intarweb http-client
-;; spiffy-request-vars uri-common intarweb directory-utils)
-;;
-;; (declare (unit client))
-;;
-;; (declare (uses common))
-;; (declare (uses db))
-;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-
-;; client:get-signature
-(define (client:get-signature)
- (if *my-client-signature* *my-client-signature*
- (let ((sig (conc (get-host-name) " " (current-process-id))))
- (set! *my-client-signature* sig)
- *my-client-signature*)))
-
-;; Not currently used! But, I think it *should* be used!!!
-#;(define (client:logout serverdat)
- (let ((ok (and (socket? serverdat)
- (cdb:logout serverdat *toppath* (client:get-signature)))))
- ok))
-
-#;(define (client:connect iface port)
- (http-transport:client-connect iface port)
- #;(case (server:get-transport)
- ((rpc) (rpc:client-connect iface port))
- ((http) (http:client-connect iface port))
- ((zmq) (zmq:client-connect iface port))
- (else (rpc:client-connect iface port))))
-
-(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
- (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
- #;(case (server:get-transport)
- ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
- ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
- (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
-
-;; Do all the connection work, look up the transport type and set up the
-;; connection if required.
-;;
-;; There are two scenarios.
-;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
-;; 2. We are a run tests, list runs or other interactive process and we must figure out
-;; *transport-type* and *runremote* from the monitor.db
-;;
-;; client:setup
-;;
-;; lookup_server, need to remove *runremote* stuff
-;;
-
-(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
- (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
- (server:start-and-wait areapath)
- (if (<= remaining-tries 0)
- (begin
- (debug:print-error 0 *default-log-port* "failed to start or connect to server")
- (exit 1))
- ;;
- ;; Alternatively here, we can get the list of candidate servers and work our way
- ;; through them searching for a good one.
- ;;
- (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath))
- (runremote (or area-dat *runremote*)))
- (if (not server-dat) ;; no server found
- (client:setup-http areapath remaining-tries: (- remaining-tries 1))
- (let ((host (cadr server-dat))
- (port (caddr server-dat))
- (server-id (caddr (cddr server-dat))))
- (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
- (if (and (not area-dat)
- (not *runremote*))
- (begin
- (set! *runremote* (make-and-init-remote))
- (let* ((server-info (remote-server-info *runremote*)))
- (if server-info
- (begin
- (remote-server-url-set! *runremote* (server:record->url server-info))
- (remote-server-id-set! *runremote* (server:record->id server-info)))))))
- (if (and host port server-id)
- (let* ((start-res (case *transport-type*
- ((http)(http-transport:client-connect host port server-id))))
- (ping-res (case *transport-type*
- ((http)(rmt:login-no-auto-client-setup start-res)))))
- (if (and start-res
- ping-res)
- (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
- (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
- (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
- start-res)
- (begin ;; login failed but have a server record, clean out the record and try again
- (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
- (case *transport-type*
- ((http)(http-transport:close-connections)))
- (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
- (thread-sleep! 1)
- (client:setup-http areapath remaining-tries: (- remaining-tries 1))
- )))
- (begin ;; no server registered
- ;; (server:kind-run areapath)
- (server:start-and-wait areapath)
- (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
- (thread-sleep! 1) ;; (+ 5 (pseudo-random-integer (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
- (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))
-
ADDED clientmod.scm
Index: clientmod.scm
==================================================================
--- /dev/null
+++ clientmod.scm
@@ -0,0 +1,174 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit clientmod))
+(declare (uses commonmod))
+(declare (uses debugprint))
+(declare (uses configfmod))
+(declare (uses http-transportmod))
+(declare (uses servermod))
+
+(module clientmod
+ *
+
+(import scheme
+ chicken.base
+ chicken.string
+ chicken.process
+ chicken.io
+ chicken.time
+ chicken.condition
+ chicken.file
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.random
+ chicken.file.posix
+
+ system-information
+ (prefix sqlite3 sqlite3:)
+ typed-records
+ regex
+ directory-utils
+ matchable
+
+ srfi-18
+ srfi-69
+
+ commonmod
+ debugprint
+ configfmod
+ http-transportmod
+ servermod
+
+ )
+
+;;======================================================================
+;; C L I E N T S
+;;======================================================================
+
+;; (use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
+;; message-digest matchable spiffy uri-common intarweb http-client
+;; spiffy-request-vars uri-common intarweb directory-utils)
+;;
+;; (declare (unit client))
+;;
+;; (declare (uses common))
+;; (declare (uses db))
+;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+
+;; client:get-signature
+(define (client:get-signature)
+ (if *my-client-signature* *my-client-signature*
+ (let ((sig (conc (get-host-name) " " (current-process-id))))
+ (set! *my-client-signature* sig)
+ *my-client-signature*)))
+
+;; Not currently used! But, I think it *should* be used!!!
+#;(define (client:logout serverdat)
+ (let ((ok (and (socket? serverdat)
+ (cdb:logout serverdat *toppath* (client:get-signature)))))
+ ok))
+
+#;(define (client:connect iface port)
+ (http-transport:client-connect iface port)
+ #;(case (server:get-transport)
+ ((rpc) (rpc:client-connect iface port))
+ ((http) (http:client-connect iface port))
+ ((zmq) (zmq:client-connect iface port))
+ (else (rpc:client-connect iface port))))
+
+(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
+ (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
+ #;(case (server:get-transport)
+ ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
+ ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
+ (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
+
+;; Do all the connection work, look up the transport type and set up the
+;; connection if required.
+;;
+;; There are two scenarios.
+;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
+;; 2. We are a run tests, list runs or other interactive process and we must figure out
+;; *transport-type* and *runremote* from the monitor.db
+;;
+;; client:setup
+;;
+;; lookup_server, need to remove *runremote* stuff
+;;
+
+(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
+ (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
+ (server:start-and-wait areapath)
+ (if (<= remaining-tries 0)
+ (begin
+ (debug:print-error 0 *default-log-port* "failed to start or connect to server")
+ (exit 1))
+ ;;
+ ;; Alternatively here, we can get the list of candidate servers and work our way
+ ;; through them searching for a good one.
+ ;;
+ (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath))
+ (runremote (or area-dat *runremote*)))
+ (if (not server-dat) ;; no server found
+ (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ (let ((host (cadr server-dat))
+ (port (caddr server-dat))
+ (server-id (caddr (cddr server-dat))))
+ (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+ (if (and (not area-dat)
+ (not *runremote*))
+ (begin
+ (set! *runremote* (make-and-init-remote))
+ (let* ((server-info (remote-server-info *runremote*)))
+ (if server-info
+ (begin
+ (remote-server-url-set! *runremote* (server:record->url server-info))
+ (remote-server-id-set! *runremote* (server:record->id server-info)))))))
+ (if (and host port server-id)
+ (let* ((start-res (case *transport-type*
+ ((http)(http-transport:client-connect host port server-id))))
+ (ping-res (case *transport-type*
+ ((http)(rmt:login-no-auto-client-setup start-res)))))
+ (if (and start-res
+ ping-res)
+ (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
+ (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
+ (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
+ start-res)
+ (begin ;; login failed but have a server record, clean out the record and try again
+ (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
+ (case *transport-type*
+ ((http)(http-transport:close-connections)))
+ (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
+ (thread-sleep! 1)
+ (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ )))
+ (begin ;; no server registered
+ ;; (server:kind-run areapath)
+ (server:start-and-wait areapath)
+ (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
+ (thread-sleep! 1) ;; (+ 5 (pseudo-random-integer (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
+ (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))
+
+)
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -170,84 +170,10 @@
;; (define (mddb:get-dashboards)
;; (let ((db (mddb:open-db)))
;; (query fetch-column
;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
-;;======================================================================
-;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
-;;======================================================================
-;;
-;; [hosts]
-;; arm cubie01 cubie02
-;; x86_64 zeus xena myth01
-;; allhosts #{g hosts arm} #{g hosts x86_64}
-;;
-;; [host-types]
-;; general #MTLOWESTLOAD #{g hosts allhosts}
-;; arm #MTLOWESTLOAD #{g hosts arm}
-;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
-;;
-;; [host-rules]
-;; # maxnload => max normalized load
-;; # maxnjobs => max jobs per cpu
-;; # maxjobrate => max jobs per second
-;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1
-;;
-;; [launchers]
-;; envsetup general
-;; xor/%/n 4C16G
-;; % nbgeneral
-;;
-;; [jobtools]
-;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
-;; flexi-launcher yes
-;; launcher nbfake
-;;
-(define (common:get-launcher configdat testname itempath)
- (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
- (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
- (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
- (let* ((launchers (hash-table-ref/default configdat "launchers" '())))
- (if (null? launchers)
- fallback-launcher
- (let loop ((hed (car launchers))
- (tal (cdr launchers)))
- (let ((patt (car hed))
- (host-type (cadr hed)))
- (if (tests:match patt testname itempath)
- (begin
- (debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
- (let ((launcher (configf:lookup configdat "host-types" host-type)))
- (if launcher
- (let* ((launcher-parts (string-split launcher))
- (launcher-exe (car launcher-parts)))
- (if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
- (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
- (count 100))
- (if targ-host
- (conc "remrun " targ-host)
- (if (> count 0)
- (begin
- (debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
- (thread-sleep! (- 101 count))
- (host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
- (- count 1)))
- (begin
- (debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
- (exit)))))
- launcher))
- (begin
- (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
- (if (null? tal)
- fallback-launcher
- (loop (car tal)(cdr tal)))))))
- ;; no match, try again
- (if (null? tal)
- fallback-launcher
- (loop (car tal)(cdr tal))))))))
- fallback-launcher)))
-
;;======================================================================
;; faux-lock is deprecated. Please use simple-lock below
;;
(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
(if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
@@ -269,142 +195,10 @@
(begin
(if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname))
#t)
#f))
-;;======================================================================
-;; simple lock. improve and converge on this one.
-;;
-(define (common:simple-lock keyname)
- (rmt:no-sync-get-lock keyname))
-
-(define (common:simple-unlock keyname #!key (force #f))
- (rmt:no-sync-del! keyname))
-
-;;======================================================================
-;; ideally put all this info into the db, no need to preserve it across moving homehost
-;;
-;; return list of
-;; ( reachable? cpuload update-time )
-(define (common:get-host-info hostname)
- (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
- (load (car loadinfo))
- (load-sample-time (cdr loadinfo))
- (load-sample-age (- (current-seconds) load-sample-time))
- (loadinfo-timeout-seconds 6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
- (host-last-update-timeout-seconds 4)
- (host-rec (hash-table-ref/default *host-loads* hostname #f))
- )
- (cond
- ((< load-sample-age loadinfo-timeout-seconds)
- (list #t
- load-sample-time
- load))
- ((and host-rec
- (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
- (list #t
- (host-last-update host-rec)
- (host-last-cpuload host-rec )))
- ((common:unix-ping hostname)
- (list #t
- (current-seconds)
- (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
- (else
- (list #f 0 -1) ;; bad host, don't use!
- ))))
-
-;;======================================================================
-;; see defstruct host at top of file.
-;; host: reachable last-update last-used last-cpuload
-;;
-(define (common:update-host-loads-table hosts-raw)
- (let* ((hosts (filter (lambda (x)
- (string-match (regexp "^\\S+$") x))
- hosts-raw)))
- (for-each
- (lambda (hostname)
- (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f)))
- (if h
- h
- (let ((h (make-host)))
- (hash-table-set! *host-loads* hostname h)
- h))))
- (host-info (common:get-host-info hostname))
- (is-reachable (car host-info))
- (last-reached-time (cadr host-info))
- (load (caddr host-info)))
- (host-reachable-set! rec is-reachable)
- (host-last-update-set! rec last-reached-time)
- (host-last-cpuload-set! rec load)))
- hosts)))
-
-;;======================================================================
-;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
-;; [host-rules] section.
-;;
-(define (common:get-least-loaded-host hosts-raw host-type configdat)
- (let* ((rdat (configf:lookup configdat "host-rules" host-type))
- (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate
- (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
- (maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
- (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
- (hosts (filter (lambda (x)
- (string-match (regexp "^\\S+$") x))
- hosts-raw))
- ;; (best-host #f)
- (get-rec (lambda (hostname)
- ;; (print "get-rec hostname=" hostname)
- (let ((h (hash-table-ref/default *host-loads* hostname #f)))
- (if h
- h
- (let ((h (make-host)))
- (hash-table-set! *host-loads* hostname h)
- h)))))
- (best-load 99999)
- (curr-time (current-seconds))
- (get-hosts-sorted (lambda (hosts)
- (sort hosts (lambda (a b)
- (let ((a-rec (get-rec a))
- (b-rec (get-rec b)))
- ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
- ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
- (< (host-last-used a-rec)
- (host-last-used b-rec))))))))
- (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
- (if (null? hosts)
- #f ;; no hosts to select from. All done and giving up now.
- (let ((hosts-sorted (get-hosts-sorted hosts)))
- (common:update-host-loads-table hosts)
- (let loop ((hostname (car hosts-sorted))
- (tal (cdr hosts-sorted))
- (best-host #f))
- (let* ((rec (get-rec hostname))
- (reachable (host-reachable rec))
- (load (host-last-cpuload rec))
- (last-used (host-last-used rec))
- (delta (- curr-time last-used))
- (job-rate (if (> delta 0)
- (/ 1 delta)
- 999)) ;; jobs per second
- (new-best
- (cond
- ((not reachable)
- (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
- best-host)
- ((and (< load maxnload) ;; load is acceptable
- (< job-rate maxjobrate)) ;; job rate is acceptable
- (set! best-load load)
- hostname)
- (else best-host))))
- (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
- (if new-best
- (begin ;; found a host, return it
- (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
- (host-last-used-set! rec curr-time)
- new-best)
- (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))
-
(define (std-exit-procedure)
;;(common:telemetry-log-close)
(on-exit (lambda () 0))
;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
(let ((no-hurry (if *time-to-exit* ;; hurry up
@@ -449,14 +243,10 @@
)
)
0)
-(define (make-and-init-remote)
- (make-remote hh-dat: (common:get-homehost)
- server-info: (if *toppath* (server:check-if-running *toppath*) #f)
- server-timeout: (server:expiration-timeout)))
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(set! *watchdog* (make-thread
(lambda ()
(handle-exceptions
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -25,10 +25,11 @@
(declare (uses pkts))
(declare (uses processmod))
(declare (uses mtargs))
(declare (uses configfmod))
(declare (uses hostinfo))
+(declare (uses keysmod))
;; odd but it works?
(declare (uses itemsmod))
(module commonmod
@@ -76,11 +77,11 @@
stml2
pkts
processmod
(prefix mtargs args:)
configfmod
-
+ keysmod
itemsmod
hostinfo
)
;;======================================================================
@@ -100,10 +101,11 @@
;; (define unsetenv unset-environment-variable!)
;; (define getenv get-environment-variable)
(define home (getenv "HOME"))
(define user (getenv "USER"))
+(define keys:config-get-fields common:get-fields)
;; Globals
;;
(define *server-loop-heart-beat* (current-seconds))
@@ -1287,14 +1289,10 @@
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
-(define (common:get-fields cfgdat)
- (let ((fields (hash-table-ref/default cfgdat "fields" '())))
- (map car fields)))
-
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
@@ -3571,7 +3569,53 @@
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
(common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
(* 3600 (string->number tmo))
60)))
+
+(define (runs:get-mt-env-alist run-id runname target testname itempath)
+ ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
+ `(("MT_TEST_NAME" . ,testname)
+
+ ("MT_ITEMPATH" . ,itempath)
+
+ ("MT_TARGET" . ,target)
+
+ ("MT_RUNNAME" . ,runname)
+
+ ("MT_RUN_AREA_HOME" . ,*toppath*)
+
+ ,@(let* ((link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (if link-tree
+ (list (cons "MT_LINKTREE" link-tree)
+
+ (cons "MT_TEST_RUN_DIR"
+ (conc link-tree "/" target "/" runname "/" testname
+ (if (and (string? itempath) (not (equal? itempath "")))
+ (conc "/" itempath)
+ "")))
+ )
+ '()))
+
+ ,@(map
+ (lambda (key)
+ (cons (car key) (cadr key)))
+ (keys:target->keyval (common:get-fields *configdat*) #;(rmt:get-keys) target))
+
+ ,@(map (lambda (var)
+ (let ((val (configf:lookup *configdat* "env-override" var)))
+ (cons var val)))
+ (configf:section-vars *configdat* "env-override"))))
+
+;;======================================================================
+;; config file related routines
+;;======================================================================
+
+(define (keys:make-key/field-string confdat)
+ (let ((fields (configf:get-section confdat "fields")))
+ (string-join
+ (map (lambda (field)(conc (car field) " " (cadr field)))
+ fields)
+ ",")))
+
)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -16,819 +16,5 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-;;======================================================================
-;; Config file handling
-;;======================================================================
-
-;; (use regex regex-case matchable) ;; directory-utils)
-;; (declare (unit configf))
-;; (declare (uses process))
-;; (declare (uses env))
-;; (declare (uses keys))
-;;
-;; (include "common_records.scm")
-
-;; return list (path fullpath configname)
-(define (find-config configname #!key (toppath #f))
- (if toppath
- (let ((cfname (conc toppath "/" configname)))
- (if (common:file-exists? cfname)
- (list toppath cfname configname)
- (list #f #f #f)))
- (let* ((cwd (string-split (current-directory) "/")))
- (let loop ((dir cwd))
- (let* ((path (conc "/" (string-intersperse dir "/")))
- (fullpath (conc path "/" configname)))
- (if (common:file-exists? fullpath)
- (list path fullpath configname)
- (let ((remcwd (take dir (- (length dir) 1))))
- (if (null? remcwd)
- (list #f #f #f) ;; #f #f)
- (loop remcwd)))))))))
-
-(define (configf:assoc-safe-add alist key val #!key (metadata #f))
- (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
- (append newalist (list (if metadata
- (list key val metadata)
- (list key val))))))
-
-(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
- (hash-table-set! cfgdat section-name
- (configf:assoc-safe-add
- (hash-table-ref/default cfgdat section-name '())
- var value metadata: metadata)))
-
-(define (configf:eval-string-in-environment str)
- ;; (if (or (string-null? str)
- ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment
- str
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn)
- #f)
- (let ((cmdres (process:cmd-run->list (conc "echo " str))))
- (if (null? cmdres) ""
- (caar cmdres))))) ;; )
-
-;;======================================================================
-;; Make the regexp's needed globally available
-;;======================================================================
-
-(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
-(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
-(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
-(define configf:blank-l-rx (regexp "^\\s*$"))
-(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
-(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
-(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
-(define configf:comment-rx (regexp "^\\s*#.*"))
-(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
-(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)))
- (if matchdat
- (let* ((prestr (list-ref matchdat 1))
- (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
- (cmd (list-ref matchdat 3))
- (poststr (list-ref matchdat 4))
- (result #f)
- (start-time (current-seconds))
- (cmdsym (string->symbol cmdtype))
- (fullcmd (case cmdsym
- ((scheme scm) (conc "(lambda (ht)" 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 "\"))"
- " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
- " (if (string-null? extra) \"\" \"/\")"
- " extra)))"))
- ((get g)
- (match (string-split cmd)
- ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
- (else
- (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
- "(lambda (ht) #f)")))
- ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
- ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
- (else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
- ;; (print "fullcmd=" fullcmd)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- ;; (print "exn=" (condition->list exn))
- (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
- (if (or allow-system
- (not (member cmdtype '("system" "shell" "sh"))))
- (with-input-from-string fullcmd
- (lambda ()
- (set! result ((eval (read)) ht))))
- (set! result (conc "#{(" cmdtype ") " cmd "}"))))
- (case cmdsym
- ((system shell scheme)
- (let ((delta (- (current-seconds) start-time)))
- (if (> delta 2)
- (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
- (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
- (loop (conc prestr result poststr)))
- res))
- res)))
-
-;; Run a shell command and return the output as a string
-(define (shell cmd)
- (let* ((output (process:cmd-run->list cmd))
- (res (car output))
- (status (cadr output)))
- (if (equal? status 0)
- (let ((outres (string-intersperse
- res
- "\n")))
- (debug:print-info 4 *default-log-port* "shell result:\n" outres)
- outres)
- (begin
- (with-output-to-port (current-error-port)
- (lambda ()
- (print "ERROR: " cmd " returned bad exit code " status)))
- ""))))
-
-;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
-;;
-(define (configf:read-line p ht allow-processing settings)
- (let loop ((inl (read-line p)))
- (let ((cont-line (and (string? inl)
- (not (string-null? inl))
- (equal? "\\" (string-take-right inl 1)))))
- (if cont-line ;; last character is \
- (let ((nextl (read-line p)))
- (if (not (eof-object? nextl))
- (loop (string-append (if cont-line
- (string-take inl (- (string-length inl) 1))
- inl)
- nextl))))
- (let ((res (case allow-processing ;; if (and allow-processing
- ;; (not (eq? allow-processing 'return-string)))
- ((#t #f)
- (configf:process-line inl ht allow-processing))
- ((return-string)
- inl)
- (else
- (configf:process-line inl ht allow-processing)))))
- (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
- (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "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
- allow-system))
-
-;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
-;; remove the section when done so that there is no downstream clobbering
-;;
-(define (configf:apply-wildcards ht section-name)
- (if (hash-table-exists? ht section-name)
- (let* ((vars (hash-table-ref ht section-name))
- (rxstr (if (string-contains section-name "%")
- (string-substitute (regexp "%") ".*" section-name)
- (string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
- (rx (regexp rxstr)))
- ;; (print "\nsection-name: " section-name " rxstr: " rxstr)
- (for-each
- (lambda (section)
- (if section
- (let ((same-section (string=? section-name section))
- (rx-match (string-match rx section)))
- ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
- (if (and (not same-section) rx-match)
- (for-each
- (lambda (bundle)
- ;; (print "bundle: " bundle)
- (let ((key (car bundle))
- (val (cadr bundle))
- (meta (if (> (length bundle) 2)(caddr bundle) #f)))
- (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
- vars)))))
- (hash-table-keys ht))))
- ht)
-
-;; 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)
- (sections #f) (settings (make-hash-table)) (keep-filenames #f)
- (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?
- #f) ;; (if (not ht)(make-hash-table) ht))
- (let ((inp (if (string? path)
- (open-input-file path)
- path)) ;; we can be handed a port
- (res (if (not ht)(make-hash-table) ht))
- (metapath (if (or (debug:debug-mode 9)
- keep-filenames)
- path #f))
- (process-wildcards (lambda (res curr-section-name)
- (if (and apply-wildcards
- (or (string-contains curr-section-name "%") ;; wildcard
- (string-match "/.*/" curr-section-name))) ;; regex
- (begin
- (configf:apply-wildcards res curr-section-name)
- (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
- (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
- (curr-section-name (if curr-section curr-section "default"))
- (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
- (lead #f))
- (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
- (if (eof-object? inl)
- (begin
- ;; process last section for wildcards
- (process-wildcards res curr-section-name)
- (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
- (close-input-port inp))
- (if (list? sections) ;; delete all sections except given when sections is provided
- (for-each
- (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
- ) ;; 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 (and (absolute-pathname? include-file) (file-exists? include-file))
- include-file
- (common:nice-path
- (conc (if curr-conf-dir
- curr-conf-dir
- ".")
- "/" include-file)))))
- (let ((all-matches (sort (handle-exceptions exn
- (begin
- (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
- (list))
- (glob full-conf)) string<=?)))
- (if (null? all-matches)
- (begin
- (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
- (debug:print 2 *default-log-port* " " full-conf))
- (for-each
- (lambda (fpath)
- ;; (push-directory conf-dir)
- (debug:print 9 *default-log-port* "Including: " full-conf)
- (read-config fpath res allow-system environ-patt: environ-patt
- curr-section: curr-section-name sections: sections settings: settings
- keep-filenames: keep-filenames))
- all-matches))
- (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-executable? 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
- (configf: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
- (configf: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) ;; does the section match the envionpatt?
- (and (not (string-null? key))
- (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
- ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
- ))
- (realval (if envar
- (configf: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
- (configf: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
- (configf: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
- (configf: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))))
- ) ;; 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))
- (toppath (car configinfo))
- (configfile (cadr configinfo))
- (set-fields (lambda (curr-section next-section ht path)
- (let ((field-names (if ht (common:get-fields ht) '()))
- (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
- (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
- (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
- (if toppath (change-directory toppath))
- (if (and toppath pathenvvar)(setenv pathenvvar toppath))
- (let ((configdat (if configfile
- (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
- (if toppath (change-directory curr-dir))
- (list configdat toppath configfile fname))))
-
-(define (configf:lookup cfgdat section var)
- (if (hash-table? cfgdat)
- (let ((sectdat (hash-table-ref/default cfgdat section '())))
- (if (null? sectdat)
- #f
- (let ((match (assoc var sectdat)))
- (if match ;; (and match (list? match)(> (length match) 1))
- (cadr match)
- #f))
- ))
- #f))
-
-;; use to have definitive setting:
-;; [foo]
-;; var yes
-;;
-;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
-;;
-(define (configf:var-is? cfgdat section var expected-val)
- (equal? (configf:lookup cfgdat section var) expected-val))
-
-;; redefines
-(define config-lookup configf:lookup)
-(define configf:read-file read-config)
-
-;; safely look up a value that is expected to be a number, return
-;; a default (#f unless provided)
-;;
-(define (configf:lookup-number cfdat section varname #!key (default #f))
- (let* ((val (configf:lookup *configdat* section varname))
- (res (if val
- (string->number (string-substitute "\\s+" "" val #t))
- #f)))
- (cond
- (res res)
- (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
- (else default))))
-
-(define (configf:section-vars cfgdat section)
- (let ((sectdat (hash-table-ref/default cfgdat section '())))
- (if (null? sectdat)
- '()
- (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
- (configf: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
- (setenv "RUN_AREA_HOME" (pathname-directory configf)))
- config))
-
-;;======================================================================
-;; Non destructive writing of config file
-;;======================================================================
-
-(define (configf:compress-multi-lines fdat)
- ;; step 1.5 - compress any continued lines
- (if (null? fdat) fdat
- (let loop ((hed (car fdat))
- (tal (cdr fdat))
- (cur "")
- (led #f)
- (res '()))
- ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
- ;; 1. remove led whitespace
- ;; 2. tack on to hed with "\n"
- (let ((match (string-match configf:cont-ln-rx hed)))
- (if match ;; blast! have to deal with a multiline
- (let* ((lead (cadr match))
- (lval (caddr match))
- (newl (conc cur "\n" lval)))
- (if (not led)(set! led lead))
- (if (null? tal)
- (set! fdat (append fdat (list newl)))
- (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
- (let ((newres (if led
- (append res (list cur hed))
- (append res (list hed)))))
- ;; prev was a multiline
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) "" #f newres))))))))
-
-;; note: I'm cheating a little here. I merely replace "\n" with "\n "
-(define (configf:expand-multi-lines fdat)
- ;; step 1.5 - compress any continued lines
- (if (null? fdat) fdat
- (let loop ((hed (car fdat))
- (tal (cdr fdat))
- (res '()))
- (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t)))))
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres))))))
-
-(define (configf:file->list fname)
- (if (common:file-exists? fname)
- (let ((inp (open-input-file fname)))
- (let loop ((inl (read-line inp))
- (res '()))
- (if (eof-object? inl)
- (begin
- (close-input-port inp)
- (reverse res))
- (loop (read-line inp)(cons inl res)))))
- '()))
-
-;;======================================================================
-;; Write a config
-;; 0. Given a refererence data structure "indat"
-;; 1. Open the output file and read it into a list
-;; 2. Flatten any multiline entries
-;; 3. Modify values per contents of "indat" and remove absent values
-;; 4. Append new values to the section (immediately after last legit entry)
-;; 5. Write out the new list
-;;======================================================================
-
-(define (configf:write-config indat fname #!key (required-sections '()))
- (let* (;; step 1: Open the output file and read it into a list
- (fdat (configf:file->list fname))
- (refdat (make-hash-table))
- (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
- (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
- (secname #f))
-
- ;; step 2: Flatten multiline entries
- (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))
-
- ;; step 3: Modify values per contents of "indat" and remove absent values
- (if (not (null? fdat))
- (let loop ((hed (car fdat))
- (tal (cadr fdat))
- (res '())
- (lnum 0))
- (regex-case
- hed
- (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
- (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
- (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
- (if (not section-hash)
- (let ((newhash (make-hash-table)))
- (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
- (set! sechash newhash))
- (set! sechash section-hash))
- (set! new hed) ;; will append this at the bottom of the loop
- (set! secname section-name)
- ))
- ;; No need to process key cmd, let it fall though to key val
- (configf:key-val-pr ( x key val )
- (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
- ;; can handle newval == #f here => that means key is removed
- (cond
- ((equal? newval val)
- (set! res (append res (list hed))))
- ((not newval) ;; key has been removed
- (set! new #f))
- ((not (equal? newval val))
- (hash-table-set! sechash key newval)
- (set! new (conc key " " newval)))
- (else
- (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
- (else
- (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed )))
- (if (not (null? tal))
- (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
- ;; drop to here when done processing, res contains modified list of lines
- (set! fdat res)))
-
- ;; step 4: Append new values to the section
- (for-each
- (lambda (section)
- (let ((sdat '()) ;; append needed bits here
- (svars (configf:section-vars indat section)))
- (for-each
- (lambda (var)
- (let ((val (configf:lookup refdat section var)))
- (if (not val) ;; this one is new
- (begin
- (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
- (set! sdat (append sdat (list (conc var " " val))))))))
- svars)
- (set! fdat (append fdat sdat))))
- (delete-duplicates (append required-sections (hash-table-keys indat))))
-
- ;; step 5: Write out new file
- (with-output-to-file fname
- (lambda ()
- (for-each
- (lambda (line)
- (print line))
- (configf:expand-multi-lines fdat))))))
-
-;;======================================================================
-;; refdb
-;;======================================================================
-
-;; reads a refdb into an assoc array of assoc arrays
-;; returns (list dat msg)
-(define (configf:read-refdb refdb-path)
- (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
- (if (not (common:file-exists? sheets-file))
- (list #f (conc "ERROR: no refdb found at " refdb-path))
- (if (not (file-readable? sheets-file))
- (list #f (conc "ERROR: refdb file not readable at " refdb-path))
- (let* ((sheets (with-input-from-file sheets-file
- (lambda ()
- (let loop ((inl (read-line))
- (res '()))
- (if (eof-object? inl)
- (reverse res)
- (loop (read-line)(cons inl res)))))))
- (data '()))
- (for-each
- (lambda (sheet-name)
- (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
- (ref-dat (configf:read-file dat-path #f #t))
- (ref-assoc (map (lambda (key)
- (list key (hash-table-ref ref-dat key)))
- (hash-table-keys ref-dat))))
- ;; (hash-table->alist ref-dat)))
- ;; (set! data (append data (list (list sheet-name ref-assoc))))))
- (set! data (cons (list sheet-name ref-assoc) data))))
- sheets)
- (list data "NO ERRORS"))))))
-
-;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
-;;
-(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
- (for-each
- (lambda (sheetname)
- (let* ((sheettmp (assoc sheetname data))
- (sheetdat (if sheettmp (cadr sheettmp) '())))
- (if initproc1 (initproc1 sheetname))
- (for-each
- (lambda (sectionname)
- (let* ((sectiontmp (assoc sectionname sheetdat))
- (sectiondat (if sectiontmp (cadr sectiontmp) '())))
- (if initproc2 (initproc2 sheetname sectionname))
- (for-each
- (lambda (varname)
- (let* ((valtmp (assoc varname sectiondat))
- (val (if valtmp (cadr valtmp) "")))
- (proc sheetname sectionname varname val)))
- (map car sectiondat))))
- (map car sheetdat))))
- (map car data))
- data)
-
-;;======================================================================
-;; C O N F I G T O / F R O M A L I S T
-;;======================================================================
-
-(define (configf:config->alist cfgdat)
- (hash-table->alist cfgdat))
-
-(define (configf:alist->config adat)
- (let ((ht (make-hash-table)))
- (for-each
- (lambda (section)
- (hash-table-set! ht (car section)(cdr section)))
- adat)
- ht))
-
-;; if
-(define (configf:read-alist fname)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn)
- #f)
- (configf:alist->config
- (with-input-from-file fname read))))
-
-(define (configf:write-alist cdat fname)
- (if (not (common:faux-lock fname))
- (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
- (let* ((dat (configf:config->alist cdat))
- (res
- (begin
- (with-output-to-file fname ;; first write out the file
- (lambda ()
- (pp dat)))
-
- (if (common:file-exists? fname) ;; now verify it is readable
- (if (configf:read-alist fname)
- #t ;; data is good.
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
- #f)
- (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
- (delete-file fname))
- #f))
- #f))))
- (common:faux-unlock fname)
- res))
-
-;; convert hierarchial list to ini format
-;;
-(define (configf:config->ini data)
- (map
- (lambda (section)
- (let ((section-name (car section))
- (section-dat (cdr section)))
- (print "\n[" section-name "]")
- (map (lambda (dat-pair)
- (let* ((var (car dat-pair))
- (val (cadr dat-pair))
- (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
- (if fname (print "# " var "=>" fname))
- (print var " " val)))
- section-dat))) ;; (print "section-dat: " section-dat))
- (hash-table->alist data)))
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -19,10 +19,11 @@
;;======================================================================
(declare (unit configfmod))
(declare (uses mtargs))
(declare (uses debugprint))
+(declare (uses keysmod))
(module configfmod
*
(import scheme
@@ -39,13 +40,14 @@
chicken.sort
chicken.string
chicken.time
debugprint
- mtargs
+ (prefix mtargs args:)
pkts
-
+ keysmod
+
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
directory-utils
@@ -1010,12 +1012,815 @@
;;======================================================================
;; DO THE LOCKING AROUND THE CALL
;;======================================================================
;;
(define (configf:write-alist cdat fname)
- #;(if (not (common:faux-lock fname))
- (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
+ ;; (if (not (common:faux-lock fname))
+ (debug:print 0 *default-log-port* "INFO: NEED LOCKING HERE " fname)
+ (let* ((dat (configf:config->alist cdat))
+ (res
+ (begin
+ (with-output-to-file fname ;; first write out the file
+ (lambda ()
+ (pp dat)))
+
+ (if (file-exists? fname) ;; now verify it is readable
+ (if (configf:read-alist fname)
+ #t ;; data is good.
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
+ #f)
+ (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
+ (delete-file fname))
+ #f))
+ #f))))
+ ;; (common:faux-unlock fname)
+ res))
+
+(define (runconfig:read fname target environ-patt)
+ (let ((ht (make-hash-table)))
+ (if target (hash-table-set! ht target '()))
+ (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
+
+;;======================================================================
+;; Config file handling
+;;======================================================================
+
+;; (use regex regex-case matchable) ;; directory-utils)
+;; (declare (unit configf))
+;; (declare (uses process))
+;; (declare (uses env))
+;; (declare (uses keys))
+;;
+;; (include "common_records.scm")
+
+;; return list (path fullpath configname)
+(define (find-config configname #!key (toppath #f))
+ (if toppath
+ (let ((cfname (conc toppath "/" configname)))
+ (if (file-exists? cfname)
+ (list toppath cfname configname)
+ (list #f #f #f)))
+ (let* ((cwd (string-split (current-directory) "/")))
+ (let loop ((dir cwd))
+ (let* ((path (conc "/" (string-intersperse dir "/")))
+ (fullpath (conc path "/" configname)))
+ (if (file-exists? fullpath)
+ (list path fullpath configname)
+ (let ((remcwd (take dir (- (length dir) 1))))
+ (if (null? remcwd)
+ (list #f #f #f) ;; #f #f)
+ (loop remcwd)))))))))
+
+(define (configf:assoc-safe-add alist key val #!key (metadata #f))
+ (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+ (append newalist (list (if metadata
+ (list key val metadata)
+ (list key val))))))
+
+(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
+ (hash-table-set! cfgdat section-name
+ (configf:assoc-safe-add
+ (hash-table-ref/default cfgdat section-name '())
+ var value metadata: metadata)))
+
+(define (configf:eval-string-in-environment str)
+ ;; (if (or (string-null? str)
+ ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment
+ str
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn)
+ #f)
+ (let ((cmdres (process:cmd-run->list (conc "echo " str))))
+ (if (null? cmdres) ""
+ (caar cmdres))))) ;; )
+
+;;======================================================================
+;; Make the regexp's needed globally available
+;;======================================================================
+
+(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
+(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
+(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
+(define configf:blank-l-rx (regexp "^\\s*$"))
+(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
+(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
+(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
+(define configf:comment-rx (regexp "^\\s*#.*"))
+(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
+(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)))
+ (if matchdat
+ (let* ((prestr (list-ref matchdat 1))
+ (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+ (cmd (list-ref matchdat 3))
+ (poststr (list-ref matchdat 4))
+ (result #f)
+ (start-time (current-seconds))
+ (cmdsym (string->symbol cmdtype))
+ (fullcmd (case cmdsym
+ ((scheme scm) (conc "(lambda (ht)" 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 "\"))"
+ " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
+ " (if (string-null? extra) \"\" \"/\")"
+ " extra)))"))
+ ((get g)
+ (match (string-split cmd)
+ ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
+ (else
+ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
+ "(lambda (ht) #f)")))
+ ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ (else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
+ ;; (print "fullcmd=" fullcmd)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (print "exn=" (condition->list exn))
+ (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
+ (if (or allow-system
+ (not (member cmdtype '("system" "shell" "sh"))))
+ (with-input-from-string fullcmd
+ (lambda ()
+ (set! result ((eval (read)) ht))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}"))))
+ (case cmdsym
+ ((system shell scheme)
+ (let ((delta (- (current-seconds) start-time)))
+ (if (> delta 2)
+ (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
+ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
+ (loop (conc prestr result poststr)))
+ res))
+ res)))
+
+;; Run a shell command and return the output as a string
+(define (shell cmd)
+ (let* ((output (process:cmd-run->list cmd))
+ (res (car output))
+ (status (cadr output)))
+ (if (equal? status 0)
+ (let ((outres (string-intersperse
+ res
+ "\n")))
+ (debug:print-info 4 *default-log-port* "shell result:\n" outres)
+ outres)
+ (begin
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print "ERROR: " cmd " returned bad exit code " status)))
+ ""))))
+
+;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
+;;
+(define (configf:read-line p ht allow-processing settings)
+ (let loop ((inl (read-line p)))
+ (let ((cont-line (and (string? inl)
+ (not (string-null? inl))
+ (equal? "\\" (string-take-right inl 1)))))
+ (if cont-line ;; last character is \
+ (let ((nextl (read-line p)))
+ (if (not (eof-object? nextl))
+ (loop (string-append (if cont-line
+ (string-take inl (- (string-length inl) 1))
+ inl)
+ nextl))))
+ (let ((res (case allow-processing ;; if (and allow-processing
+ ;; (not (eq? allow-processing 'return-string)))
+ ((#t #f)
+ (configf:process-line inl ht allow-processing))
+ ((return-string)
+ inl)
+ (else
+ (configf:process-line inl ht allow-processing)))))
+ (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
+ (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "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
+ allow-system))
+
+;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
+;; remove the section when done so that there is no downstream clobbering
+;;
+(define (configf:apply-wildcards ht section-name)
+ (if (hash-table-exists? ht section-name)
+ (let* ((vars (hash-table-ref ht section-name))
+ (rxstr (if (string-contains section-name "%")
+ (string-substitute (regexp "%") ".*" section-name)
+ (string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
+ (rx (regexp rxstr)))
+ ;; (print "\nsection-name: " section-name " rxstr: " rxstr)
+ (for-each
+ (lambda (section)
+ (if section
+ (let ((same-section (string=? section-name section))
+ (rx-match (string-match rx section)))
+ ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
+ (if (and (not same-section) rx-match)
+ (for-each
+ (lambda (bundle)
+ ;; (print "bundle: " bundle)
+ (let ((key (car bundle))
+ (val (cadr bundle))
+ (meta (if (> (length bundle) 2)(caddr bundle) #f)))
+ (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
+ vars)))))
+ (hash-table-keys ht))))
+ ht)
+
+;; 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)
+ (sections #f) (settings (make-hash-table)) (keep-filenames #f)
+ (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 (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?
+ #f) ;; (if (not ht)(make-hash-table) ht))
+ (let ((inp (if (string? path)
+ (open-input-file path)
+ path)) ;; we can be handed a port
+ (res (if (not ht)(make-hash-table) ht))
+ (metapath (if (or (debug:debug-mode 9)
+ keep-filenames)
+ path #f))
+ (process-wildcards (lambda (res curr-section-name)
+ (if (and apply-wildcards
+ (or (string-contains curr-section-name "%") ;; wildcard
+ (string-match "/.*/" curr-section-name))) ;; regex
+ (begin
+ (configf:apply-wildcards res curr-section-name)
+ (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
+ (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
+ (curr-section-name (if curr-section curr-section "default"))
+ (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
+ (lead #f))
+ (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
+ (if (eof-object? inl)
+ (begin
+ ;; process last section for wildcards
+ (process-wildcards res curr-section-name)
+ (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
+ (close-input-port inp))
+ (if (list? sections) ;; delete all sections except given when sections is provided
+ (for-each
+ (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
+ ) ;; 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 (and (absolute-pathname? include-file) (file-exists? include-file))
+ include-file
+ (common:nice-path
+ (conc (if curr-conf-dir
+ curr-conf-dir
+ ".")
+ "/" include-file)))))
+ (let ((all-matches (sort (handle-exceptions exn
+ (begin
+ (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
+ (list))
+ (glob full-conf)) string<=?)))
+ (if (null? all-matches)
+ (begin
+ (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
+ (debug:print 2 *default-log-port* " " full-conf))
+ (for-each
+ (lambda (fpath)
+ ;; (push-directory conf-dir)
+ (debug:print 9 *default-log-port* "Including: " full-conf)
+ (read-config fpath res allow-system environ-patt: environ-patt
+ curr-section: curr-section-name sections: sections settings: settings
+ keep-filenames: keep-filenames))
+ all-matches))
+ (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 (file-exists? include-script)(file-executable? 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
+ (configf: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
+ (configf: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) ;; does the section match the envionpatt?
+ (and (not (string-null? key))
+ (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
+ ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
+ ))
+ (realval (if envar
+ (configf: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
+ (configf: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
+ (configf: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
+ (configf: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))))
+ ) ;; 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))
+ (toppath (car configinfo))
+ (configfile (cadr configinfo))
+ (set-fields (lambda (curr-section next-section ht path)
+ (let ((field-names (if ht (common:get-fields ht) '()))
+ (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
+ (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
+ (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
+ (if toppath (change-directory toppath))
+ (if (and toppath pathenvvar)(setenv pathenvvar toppath))
+ (let ((configdat (if configfile
+ (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
+ (if toppath (change-directory curr-dir))
+ (list configdat toppath configfile fname))))
+
+(define (configf:lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
+
+;; use to have definitive setting:
+;; [foo]
+;; var yes
+;;
+;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
+;;
+(define (configf:var-is? cfgdat section var expected-val)
+ (equal? (configf:lookup cfgdat section var) expected-val))
+
+;; redefines
+(define config-lookup configf:lookup)
+(define configf:read-file read-config)
+
+;; safely look up a value that is expected to be a number, return
+;; a default (#f unless provided)
+;;
+(define (configf:lookup-number cfdat section varname #!key (default #f))
+ (let* ((val (configf:lookup *configdat* section varname))
+ (res (if val
+ (string->number (string-substitute "\\s+" "" val #t))
+ #f)))
+ (cond
+ (res res)
+ (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+ (else default))))
+
+(define (configf:section-vars cfgdat section)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ '()
+ (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
+ (configf: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
+ (setenv "RUN_AREA_HOME" (pathname-directory configf)))
+ config))
+
+;;======================================================================
+;; Non destructive writing of config file
+;;======================================================================
+
+(define (configf:compress-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (cur "")
+ (led #f)
+ (res '()))
+ ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
+ ;; 1. remove led whitespace
+ ;; 2. tack on to hed with "\n"
+ (let ((match (string-match configf:cont-ln-rx hed)))
+ (if match ;; blast! have to deal with a multiline
+ (let* ((lead (cadr match))
+ (lval (caddr match))
+ (newl (conc cur "\n" lval)))
+ (if (not led)(set! led lead))
+ (if (null? tal)
+ (set! fdat (append fdat (list newl)))
+ (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
+ (let ((newres (if led
+ (append res (list cur hed))
+ (append res (list hed)))))
+ ;; prev was a multiline
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) "" #f newres))))))))
+
+;; note: I'm cheating a little here. I merely replace "\n" with "\n "
+(define (configf:expand-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (res '()))
+ (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t)))))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+(define (configf:file->list fname)
+ (if (file-exists? fname)
+ (let ((inp (open-input-file fname)))
+ (let loop ((inl (read-line inp))
+ (res '()))
+ (if (eof-object? inl)
+ (begin
+ (close-input-port inp)
+ (reverse res))
+ (loop (read-line inp)(cons inl res)))))
+ '()))
+
+;;======================================================================
+;; Write a config
+;; 0. Given a refererence data structure "indat"
+;; 1. Open the output file and read it into a list
+;; 2. Flatten any multiline entries
+;; 3. Modify values per contents of "indat" and remove absent values
+;; 4. Append new values to the section (immediately after last legit entry)
+;; 5. Write out the new list
+;;======================================================================
+
+(define (configf:write-config indat fname #!key (required-sections '()))
+ (let* (;; step 1: Open the output file and read it into a list
+ (fdat (configf:file->list fname))
+ (refdat (make-hash-table))
+ (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
+ (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
+ (secname #f))
+
+ ;; step 2: Flatten multiline entries
+ (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))
+
+ ;; step 3: Modify values per contents of "indat" and remove absent values
+ (if (not (null? fdat))
+ (let loop ((hed (car fdat))
+ (tal (cadr fdat))
+ (res '())
+ (lnum 0))
+ (regex-case
+ hed
+ (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
+ (if (not section-hash)
+ (let ((newhash (make-hash-table)))
+ (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
+ (set! sechash newhash))
+ (set! sechash section-hash))
+ (set! new hed) ;; will append this at the bottom of the loop
+ (set! secname section-name)
+ ))
+ ;; No need to process key cmd, let it fall though to key val
+ (configf:key-val-pr ( x key val )
+ (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
+ ;; can handle newval == #f here => that means key is removed
+ (cond
+ ((equal? newval val)
+ (set! res (append res (list hed))))
+ ((not newval) ;; key has been removed
+ (set! new #f))
+ ((not (equal? newval val))
+ (hash-table-set! sechash key newval)
+ (set! new (conc key " " newval)))
+ (else
+ (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
+ (else
+ (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed )))
+ (if (not (null? tal))
+ (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
+ ;; drop to here when done processing, res contains modified list of lines
+ (set! fdat res)))
+
+ ;; step 4: Append new values to the section
+ (for-each
+ (lambda (section)
+ (let ((sdat '()) ;; append needed bits here
+ (svars (configf:section-vars indat section)))
+ (for-each
+ (lambda (var)
+ (let ((val (configf:lookup refdat section var)))
+ (if (not val) ;; this one is new
+ (begin
+ (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
+ (set! sdat (append sdat (list (conc var " " val))))))))
+ svars)
+ (set! fdat (append fdat sdat))))
+ (delete-duplicates (append required-sections (hash-table-keys indat))))
+
+ ;; step 5: Write out new file
+ (with-output-to-file fname
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (print line))
+ (configf:expand-multi-lines fdat))))))
+
+;;======================================================================
+;; refdb
+;;======================================================================
+
+;; reads a refdb into an assoc array of assoc arrays
+;; returns (list dat msg)
+(define (configf:read-refdb refdb-path)
+ (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
+ (if (not (file-exists? sheets-file))
+ (list #f (conc "ERROR: no refdb found at " refdb-path))
+ (if (not (file-readable? sheets-file))
+ (list #f (conc "ERROR: refdb file not readable at " refdb-path))
+ (let* ((sheets (with-input-from-file sheets-file
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (eof-object? inl)
+ (reverse res)
+ (loop (read-line)(cons inl res)))))))
+ (data '()))
+ (for-each
+ (lambda (sheet-name)
+ (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
+ (ref-dat (configf:read-file dat-path #f #t))
+ (ref-assoc (map (lambda (key)
+ (list key (hash-table-ref ref-dat key)))
+ (hash-table-keys ref-dat))))
+ ;; (hash-table->alist ref-dat)))
+ ;; (set! data (append data (list (list sheet-name ref-assoc))))))
+ (set! data (cons (list sheet-name ref-assoc) data))))
+ sheets)
+ (list data "NO ERRORS"))))))
+
+;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
+;;
+(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
+ (for-each
+ (lambda (sheetname)
+ (let* ((sheettmp (assoc sheetname data))
+ (sheetdat (if sheettmp (cadr sheettmp) '())))
+ (if initproc1 (initproc1 sheetname))
+ (for-each
+ (lambda (sectionname)
+ (let* ((sectiontmp (assoc sectionname sheetdat))
+ (sectiondat (if sectiontmp (cadr sectiontmp) '())))
+ (if initproc2 (initproc2 sheetname sectionname))
+ (for-each
+ (lambda (varname)
+ (let* ((valtmp (assoc varname sectiondat))
+ (val (if valtmp (cadr valtmp) "")))
+ (proc sheetname sectionname varname val)))
+ (map car sectiondat))))
+ (map car sheetdat))))
+ (map car data))
+ data)
+
+;;======================================================================
+;; C O N F I G T O / F R O M A L I S T
+;;======================================================================
+
+(define (configf:config->alist cfgdat)
+ (hash-table->alist cfgdat))
+
+(define (configf:alist->config adat)
+ (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (section)
+ (hash-table-set! ht (car section)(cdr section)))
+ adat)
+ ht))
+
+;; if
+(define (configf:read-alist fname)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn)
+ #f)
+ (configf:alist->config
+ (with-input-from-file fname read))))
+
+(define (configf:write-alist cdat fname)
+ ;; (if (not (common:faux-lock fname))
+ (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname)
(let* ((dat (configf:config->alist cdat))
(res
(begin
(with-output-to-file fname ;; first write out the file
(lambda ()
@@ -1035,7 +1840,27 @@
#f))
#f))))
;; (common:faux-unlock fname)
res))
+;; convert hierarchial list to ini format
+;;
+(define (configf:config->ini data)
+ (map
+ (lambda (section)
+ (let ((section-name (car section))
+ (section-dat (cdr section)))
+ (print "\n[" section-name "]")
+ (map (lambda (dat-pair)
+ (let* ((var (car dat-pair))
+ (val (cadr dat-pair))
+ (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
+ (if fname (print "# " var "=>" fname))
+ (print var " " val)))
+ section-dat))) ;; (print "section-dat: " section-dat))
+ (hash-table->alist data)))
+
+(define (common:get-fields cfgdat)
+ (let ((fields (hash-table-ref/default cfgdat "fields" '())))
+ (map car fields)))
)
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -15,383 +15,5 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-;; (use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
-;; z3 csv typed-records pathname-expand matchable)
-;;
-;; (declare (unit ezsteps))
-;; (declare (uses db))
-;; (declare (uses common))
-;; (declare (uses items))
-;; (declare (uses runconfig))
-;; ;; (declare (uses sdb))
-;; ;; (declare (uses filedb))
-;;
-;; (include "common_records.scm")
-;; (include "key_records.scm")
-;; (include "db_records.scm")
-;; (include "run_records.scm")
-;;
-;;
-;;(rmt:get-test-info-by-id run-id test-id) -> testdat
-
-(define message-window #f)
-
-;; TODO: deprecate me in favor of ezsteps.scm
-;;
-(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
- (let* ((stepname (car ezstep)) ;; do stuff to run the step
- (stepinfo (cadr ezstep))
- ;; (let ((info (cadr ezstep)))
- ;; (if (proc? info) "" info)))
- ;; (stepproc (let ((info (cadr ezstep)))
- ;; (if (proc? info) info #f)))
- (stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
- (stepparams (if (and (list? stepparts)
- (> (length stepparts) 1))
- (list-ref stepparts 2)
- #f)) ;; for future use, {VAR=1,2,3}, run step for each
- (paramparts (if (string? stepparams)
- (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
- '()))
- (subrun (alist-ref "subrun" paramparts equal?))
- (stepcmd (if (and (list? stepparts)
- (> (length stepparts) 2))
- (list-ref stepparts 3)
- (conc "# error, no command for step "stepname)))
- (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
- (logpro-file (conc stepname ".logpro"))
- (html-file (conc stepname ".html"))
- (dat-file (conc stepname ".dat"))
- (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
- (logpro-used (common:file-exists? logpro-file)))
- (setenv "MT_STEP_NAME" stepname)
- (hash-table-set! all-steps-dat stepname `((params . ,paramparts)))
- (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
- ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
-
- (if (and tconfig-logpro
- (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
- (begin
- (with-output-to-file logpro-file
- (lambda ()
- (print ";; logpro file extracted from testconfig\n"
- ";;")
- (print tconfig-logpro)))
- (set! logpro-used #t)))
-
- ;; NB// can safely assume we are in test-area directory
- (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
- " stepparams: " stepparams " stepcmd: " stepcmd)
-
- ;; ;; first source the previous environment
- ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh")
- ;; (get-environment-variable "SHELL")) ".csh" ".sh"))))
- ;; (if (and prevstep (common:file-exists? prev-env))
- ;; (set! script (conc script "source " prev-env))))
-
- ;; call the command using mt_ezstep
- ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
-
- (debug:print 4 *default-log-port* "script: " script)
- (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
- ;; now launch the actual process
- (call-with-environment-variables
- (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
- (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
- (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1
- (pid #f))
- (let ((proc (lambda ()
- (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
- (if subrun
- (begin
- (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
- (common:without-vars proc "^MT_.*"))
- (proc)))
-
- (with-output-to-file "Makefile.ezsteps"
- (lambda ()
- (print stepname ".log :")
- (print "\t" cmd)
- (if (common:file-exists? (conc stepname ".logpro"))
- (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
- (print)
- (print stepname " : " stepname ".log")
- (print))
- #:append)
-
- (rmt:test-set-top-process-pid run-id test-id pid)
- (let processloop ((i 0))
- (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
- (mutex-lock! m)
- (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
- (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
- (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
- (mutex-unlock! m)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 2)
- (processloop (+ i 1))))
- )))))
- (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
- ;; now run logpro if needed
- (if logpro-used
- (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
- (pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
- (let processloop ((i 0))
- (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
- (mutex-lock! m)
- ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
- (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
- (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
- (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
- (mutex-unlock! m)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 2)
- (processloop (+ i 1)))))
- (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
-
- (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
- (logfna (if logpro-used (conc stepname ".html") ""))
- (comment #f))
- (if logpro-used
- (let ((datfile (conc stepname ".dat")))
- ;; load the .dat file into the test_data table if it exists
- (if (common:file-exists? datfile)
- (set! comment (launch:load-logpro-dat run-id test-id stepname)))
- (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
- (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
- ;; set the test final status
- (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
- (this-step-status (cond
- ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings
- ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check
- ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived
- ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort
- ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip
- ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass
- (else 'fail)))
- (overall-status (cond
- ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3)
- ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3)
- (else 'fail)))
- (next-status (cond
- ((eq? overall-status 'pass) this-step-status)
- ((eq? overall-status 'warn)
- (if (eq? this-step-status 'fail) 'fail 'warn))
- ((eq? overall-status 'abort) 'abort)
- (else 'fail)))
- (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
- (cond
- ((null? tal) ;; more to run?
- "COMPLETED")
- (else "RUNNING"))))
- (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used
- " this-step-status: " this-step-status " overall-status: " overall-status
- " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
- (case next-status
- ((warn)
- (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "WARN"
- (if (eq? this-step-status 'warn) "Logpro warning found" #f)
- #f))
- ((check)
- (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "CHECK"
- (if (eq? this-step-status 'check) "Logpro check found" #f)
- #f))
- ((waived)
- (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "WAIVED"
- (if (eq? this-step-status 'check) "Logpro waived found" #f)
- #f))
- ((abort)
- (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "ABORT"
- (if (eq? this-step-status 'abort) "Logpro abort found" #f)
- #f))
- ((skip)
- (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "SKIP"
- (if (eq? this-step-status 'skip) "Logpro skip found" #f)
- #f))
- ((pass)
- (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
- (else ;; 'fail
- (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
- (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
- )))
- logpro-used))
-
-(define (ezsteps:run-from testdat start-step-name run-one)
- ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
- (let* ((do-update-test-state-status #f)
- (test-run-dir ;; (filedb:get-path *fdb*
- (db:test-get-rundir testdat)) ;; )
- (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
- (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
- (run-mutex (make-mutex))
- (rollup-status 0)
- (rollup-status-string #f)
- (rollup-status-sym #f)
- (exit-info (vector #t #t #t))
- (test-id (db:test-get-id testdat))
- (run-id (db:test-get-run_id testdat))
- (test-name (db:test-get-testname testdat))
- (orig-test-state (db:test-get-state testdat))
- (orig-test-status (db:test-get-status testdat))
- (kill-job #f) ;; for future use (on re-factoring with launch.scm code
- (the-step-params '())) ;; not exactly "functional"
-
- ;; keep trying till NFS deigns to populate test run dir on this host
- (let loop ((count 5))
- (if (not (common:file-exists? test-run-dir))
- ;;(push-directory test-run-dir)
- (if (> count 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
- (sleep 3)
- (loop (- count 1))))))
-
- (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
- (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
- ;; if ezsteps was defined then we are sure to have at least one step but check anyway
-
- (if (not (> (length ezstepslst) 0))
- (if message-window
- (message-window "ERROR: You can only re-run steps defined via ezsteps")
- (debug:print 0 *default-log-port* "ERROR: You can only re-run steps defined via ezsteps"))
- (begin
- (let loop ((ezstep (car ezstepslst))
- (tal (cdr ezstepslst))
- (status-sym-so-far 'pass)
- ;;(runflag #f)
- (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
- (if (or (vector-ref exit-info 1)
- (equal? (alist-ref 'keep-going the-step-params) 'yes))
- (let* ((prev-step-params the-step-params) ;; need to snag this now
- (stepname (car ezstep)) ;; do stuff to run the step
- (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro")))
- (stepinfo (cadr ezstep))
- (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
- (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
- (stepcmd (list-ref stepparts 3))
- (script (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep
- (saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name)))
- (proceed-with-this-step
- (or (not start-step-name)
- (equal? stepname start-step-name)
- (and saw-start-step-name (not run-one))
- saw-start-step-name-next
- (and start-step-name (equal? stepname start-step-name))))
- )
- (debug:print 0 *default-log-port* "NOTE: stepparms=" stepparms)
- (set! prev-step-params stepparms)
- (set! do-update-test-state-status (and proceed-with-this-step (null? tal)))
- ;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status)
- (cond
- ((and (not proceed-with-this-step) (null? tal))
- 'done)
- ((not proceed-with-this-step)
- (loop (car tal)
- (cdr tal)
- status-sym-so-far
- saw-start-step-name-next))
- (else
- (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
- " stepparms: " stepparms " stepcmd: " stepcmd)
- (debug:print 4 *default-log-port* "script: " script)
- (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
-
- ;; now launch the script
- (let ((pid (process-run script)))
- (let processloop ((i 0))
- (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
- (mutex-lock! run-mutex)
- (vector-set! exit-info 0 pid)
- (vector-set! exit-info 1 exit-status)
- (vector-set! exit-info 2 exit-code)
- (mutex-unlock! run-mutex)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 1)
- (processloop (+ i 1))))
- ))
- (let ((exinfo (vector-ref exit-info 2))
- (logfna (if logpro-used (conc stepname ".html") "")))
- (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
-
- (if logpro-used
- (rmt:test-set-log! run-id test-id (conc stepname ".html")))
-
- ;; set the test final status
- (let* ((this-step-status (cond
- (logpro-used
- (common:logpro-exit-code->status-sym (vector-ref exit-info 2)))
- ((eq? (vector-ref exit-info 2) 0)
- 'pass)
- (else
- 'fail)))
- (overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far))
- (overall-status-string (status-sym->string overall-status-sym)))
- (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
- " this-step-status: " this-step-status " overall-status: " overall-status-sym)
- ;;" next-status: " next-status " rollup-status: " rollup-status)
- (set! rollup-status-string overall-status-string)
- (set! rollup-status-sym overall-status-sym)
- (tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f)))
-
- (if (and
- (not run-one)
- (common:steps-can-proceed-given-status-sym rollup-status-sym)
- (not (null? tal)))
- (loop (car tal)
- (cdr tal)
- rollup-status-sym
- saw-start-step-name-next)))))
- (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
-
- ;; Once done with step/steps update the test record
- ;;
- (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
- (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
- ;; Am I completed?
- (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
- (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
- ;; "COMPLETED"
- ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
- )
- (new-status rollup-status-string)
- ) ;; (db:test-get-status testinfo)))
- (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
- (tests:test-set-status! run-id test-id
- (if do-update-test-state-status new-state orig-test-state)
- (if do-update-test-state-status new-status orig-test-status)
- (args:get-arg "-m") #f)
- ;; need to update the top test record if PASS or FAIL and this is a subtest
- (if (and (not (equal? item-path "")) do-update-test-state-status)
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f))))
- ;; for automated creation of the rollup html file this is a good place...
- (if (not (equal? item-path ""))
- (tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no
- )))
- ;;(pop-directory)
- rollup-status-string))
-
-(define (ezsteps:spawn-run-from testdat start-step-name run-one)
- (thread-start!
- (make-thread
- (lambda ()
- (ezsteps:run-from testdat start-step-name run-one))
- (conc "ezstep run single step " start-step-name " run-one="run-one)))
- )
-
ADDED ezstepsmod.scm
Index: ezstepsmod.scm
==================================================================
--- /dev/null
+++ ezstepsmod.scm
@@ -0,0 +1,460 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit ezstepsmod))
+(declare (uses debugprint))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses mtargs))
+(declare (uses mtver))
+;; (declare (uses csv-xml))
+(declare (uses keysmod))
+(declare (uses mtmod))
+(declare (uses rmtmod))
+(declare (uses testsmod))
+
+(module ezstepsmod
+ *
+
+(import scheme
+ (prefix sqlite3 sqlite3:)
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ (prefix base64 base64:)
+ csv-xml
+ directory-utils
+ matchable
+ regex
+ s11n
+ srfi-1
+ srfi-13
+ srfi-18
+ srfi-69
+ stack
+ typed-records
+ z3
+
+ (prefix mtargs args:)
+ commonmod
+ configfmod
+ debugprint
+;; keysmod
+ mtmod
+ mtver
+ rmtmod
+ testsmod
+
+ )
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+;; (use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
+;; z3 csv typed-records pathname-expand matchable)
+;;
+;; (declare (unit ezsteps))
+;; (declare (uses db))
+;; (declare (uses common))
+;; (declare (uses items))
+;; (declare (uses runconfig))
+;; ;; (declare (uses sdb))
+;; ;; (declare (uses filedb))
+;;
+;; (include "common_records.scm")
+;; (include "key_records.scm")
+(include "db_records.scm")
+;; (include "run_records.scm")
+;;
+;;
+;;(rmt:get-test-info-by-id run-id test-id) -> testdat
+
+(define message-window #f)
+
+;; TODO: deprecate me in favor of ezsteps.scm
+;;
+(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
+ (let* ((stepname (car ezstep)) ;; do stuff to run the step
+ (stepinfo (cadr ezstep))
+ ;; (let ((info (cadr ezstep)))
+ ;; (if (proc? info) "" info)))
+ ;; (stepproc (let ((info (cadr ezstep)))
+ ;; (if (proc? info) info #f)))
+ (stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
+ (stepparams (if (and (list? stepparts)
+ (> (length stepparts) 1))
+ (list-ref stepparts 2)
+ #f)) ;; for future use, {VAR=1,2,3}, run step for each
+ (paramparts (if (string? stepparams)
+ (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
+ '()))
+ (subrun (alist-ref "subrun" paramparts equal?))
+ (stepcmd (if (and (list? stepparts)
+ (> (length stepparts) 2))
+ (list-ref stepparts 3)
+ (conc "# error, no command for step "stepname)))
+ (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
+ (logpro-file (conc stepname ".logpro"))
+ (html-file (conc stepname ".html"))
+ (dat-file (conc stepname ".dat"))
+ (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
+ (logpro-used (common:file-exists? logpro-file)))
+ (setenv "MT_STEP_NAME" stepname)
+ (hash-table-set! all-steps-dat stepname `((params . ,paramparts)))
+ (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
+ ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
+
+ (if (and tconfig-logpro
+ (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
+ (begin
+ (with-output-to-file logpro-file
+ (lambda ()
+ (print ";; logpro file extracted from testconfig\n"
+ ";;")
+ (print tconfig-logpro)))
+ (set! logpro-used #t)))
+
+ ;; NB// can safely assume we are in test-area directory
+ (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
+ " stepparams: " stepparams " stepcmd: " stepcmd)
+
+ ;; ;; first source the previous environment
+ ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh")
+ ;; (get-environment-variable "SHELL")) ".csh" ".sh"))))
+ ;; (if (and prevstep (common:file-exists? prev-env))
+ ;; (set! script (conc script "source " prev-env))))
+
+ ;; call the command using mt_ezstep
+ ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
+
+ (debug:print 4 *default-log-port* "script: " script)
+ (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
+ ;; now launch the actual process
+ (call-with-environment-variables
+ (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
+ (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
+ (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1
+ (pid #f))
+ (let ((proc (lambda ()
+ (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
+ (if subrun
+ (begin
+ (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
+ (common:without-vars proc "^MT_.*"))
+ (proc)))
+
+ (with-output-to-file "Makefile.ezsteps"
+ (lambda ()
+ (print stepname ".log :")
+ (print "\t" cmd)
+ (if (common:file-exists? (conc stepname ".logpro"))
+ (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
+ (print)
+ (print stepname " : " stepname ".log")
+ (print))
+ #:append)
+
+ (rmt:test-set-top-process-pid run-id test-id pid)
+ (let processloop ((i 0))
+ (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
+ (mutex-lock! m)
+ (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
+ (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
+ (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
+ (mutex-unlock! m)
+ (if (eq? pid-val 0)
+ (begin
+ (thread-sleep! 2)
+ (processloop (+ i 1))))
+ )))))
+ (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
+ ;; now run logpro if needed
+ (if logpro-used
+ (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
+ (pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
+ (let processloop ((i 0))
+ (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
+ (mutex-lock! m)
+ ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
+ (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
+ (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
+ (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
+ (mutex-unlock! m)
+ (if (eq? pid-val 0)
+ (begin
+ (thread-sleep! 2)
+ (processloop (+ i 1)))))
+ (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
+
+ (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
+ (logfna (if logpro-used (conc stepname ".html") ""))
+ (comment #f))
+ (if logpro-used
+ (let ((datfile (conc stepname ".dat")))
+ ;; load the .dat file into the test_data table if it exists
+ (if (common:file-exists? datfile)
+ (set! comment (launch:load-logpro-dat run-id test-id stepname)))
+ (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
+ (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
+ ;; set the test final status
+ (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
+ (this-step-status (cond
+ ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings
+ ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check
+ ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived
+ ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort
+ ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip
+ ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass
+ (else 'fail)))
+ (overall-status (cond
+ ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3)
+ ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3)
+ (else 'fail)))
+ (next-status (cond
+ ((eq? overall-status 'pass) this-step-status)
+ ((eq? overall-status 'warn)
+ (if (eq? this-step-status 'fail) 'fail 'warn))
+ ((eq? overall-status 'abort) 'abort)
+ (else 'fail)))
+ (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
+ (cond
+ ((null? tal) ;; more to run?
+ "COMPLETED")
+ (else "RUNNING"))))
+ (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used
+ " this-step-status: " this-step-status " overall-status: " overall-status
+ " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
+ (case next-status
+ ((warn)
+ (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status
+ ;; NB// test-set-status! does rdb calls under the hood
+ (tests:test-set-status! run-id test-id next-state "WARN"
+ (if (eq? this-step-status 'warn) "Logpro warning found" #f)
+ #f))
+ ((check)
+ (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status
+ ;; NB// test-set-status! does rdb calls under the hood
+ (tests:test-set-status! run-id test-id next-state "CHECK"
+ (if (eq? this-step-status 'check) "Logpro check found" #f)
+ #f))
+ ((waived)
+ (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status
+ ;; NB// test-set-status! does rdb calls under the hood
+ (tests:test-set-status! run-id test-id next-state "WAIVED"
+ (if (eq? this-step-status 'check) "Logpro waived found" #f)
+ #f))
+ ((abort)
+ (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status
+ ;; NB// test-set-status! does rdb calls under the hood
+ (tests:test-set-status! run-id test-id next-state "ABORT"
+ (if (eq? this-step-status 'abort) "Logpro abort found" #f)
+ #f))
+ ((skip)
+ (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
+ ;; NB// test-set-status! does rdb calls under the hood
+ (tests:test-set-status! run-id test-id next-state "SKIP"
+ (if (eq? this-step-status 'skip) "Logpro skip found" #f)
+ #f))
+ ((pass)
+ (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
+ (else ;; 'fail
+ (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
+ (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
+ )))
+ logpro-used))
+
+(define (ezsteps:run-from testdat start-step-name run-one)
+ ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
+ (let* ((do-update-test-state-status #f)
+ (test-run-dir ;; (filedb:get-path *fdb*
+ (db:test-get-rundir testdat)) ;; )
+ (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
+ (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
+ (run-mutex (make-mutex))
+ (rollup-status 0)
+ (rollup-status-string #f)
+ (rollup-status-sym #f)
+ (exit-info (vector #t #t #t))
+ (test-id (db:test-get-id testdat))
+ (run-id (db:test-get-run_id testdat))
+ (test-name (db:test-get-testname testdat))
+ (orig-test-state (db:test-get-state testdat))
+ (orig-test-status (db:test-get-status testdat))
+ (kill-job #f) ;; for future use (on re-factoring with launch.scm code
+ (the-step-params '())) ;; not exactly "functional"
+
+ ;; keep trying till NFS deigns to populate test run dir on this host
+ (let loop ((count 5))
+ (if (not (common:file-exists? test-run-dir))
+ ;;(push-directory test-run-dir)
+ (if (> count 0)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
+ (sleep 3)
+ (loop (- count 1))))))
+
+ (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
+ (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
+ ;; if ezsteps was defined then we are sure to have at least one step but check anyway
+
+ (if (not (> (length ezstepslst) 0))
+ (if message-window
+ (message-window "ERROR: You can only re-run steps defined via ezsteps")
+ (debug:print 0 *default-log-port* "ERROR: You can only re-run steps defined via ezsteps"))
+ (begin
+ (let loop ((ezstep (car ezstepslst))
+ (tal (cdr ezstepslst))
+ (status-sym-so-far 'pass)
+ ;;(runflag #f)
+ (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
+ (if (or (vector-ref exit-info 1)
+ (equal? (alist-ref 'keep-going the-step-params) 'yes))
+ (let* ((prev-step-params the-step-params) ;; need to snag this now
+ (stepname (car ezstep)) ;; do stuff to run the step
+ (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro")))
+ (stepinfo (cadr ezstep))
+ (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
+ (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
+ (stepcmd (list-ref stepparts 3))
+ (script (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep
+ (saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name)))
+ (proceed-with-this-step
+ (or (not start-step-name)
+ (equal? stepname start-step-name)
+ (and saw-start-step-name (not run-one))
+ saw-start-step-name-next
+ (and start-step-name (equal? stepname start-step-name))))
+ )
+ (debug:print 0 *default-log-port* "NOTE: stepparms=" stepparms)
+ (set! prev-step-params stepparms)
+ (set! do-update-test-state-status (and proceed-with-this-step (null? tal)))
+ ;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status)
+ (cond
+ ((and (not proceed-with-this-step) (null? tal))
+ 'done)
+ ((not proceed-with-this-step)
+ (loop (car tal)
+ (cdr tal)
+ status-sym-so-far
+ saw-start-step-name-next))
+ (else
+ (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
+ " stepparms: " stepparms " stepcmd: " stepcmd)
+ (debug:print 4 *default-log-port* "script: " script)
+ (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
+
+ ;; now launch the script
+ (let ((pid (process-run script)))
+ (let processloop ((i 0))
+ (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
+ (mutex-lock! run-mutex)
+ (vector-set! exit-info 0 pid)
+ (vector-set! exit-info 1 exit-status)
+ (vector-set! exit-info 2 exit-code)
+ (mutex-unlock! run-mutex)
+ (if (eq? pid-val 0)
+ (begin
+ (thread-sleep! 1)
+ (processloop (+ i 1))))
+ ))
+ (let ((exinfo (vector-ref exit-info 2))
+ (logfna (if logpro-used (conc stepname ".html") "")))
+ (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
+
+ (if logpro-used
+ (rmt:test-set-log! run-id test-id (conc stepname ".html")))
+
+ ;; set the test final status
+ (let* ((this-step-status (cond
+ (logpro-used
+ (common:logpro-exit-code->status-sym (vector-ref exit-info 2)))
+ ((eq? (vector-ref exit-info 2) 0)
+ 'pass)
+ (else
+ 'fail)))
+ (overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far))
+ (overall-status-string (status-sym->string overall-status-sym)))
+ (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
+ " this-step-status: " this-step-status " overall-status: " overall-status-sym)
+ ;;" next-status: " next-status " rollup-status: " rollup-status)
+ (set! rollup-status-string overall-status-string)
+ (set! rollup-status-sym overall-status-sym)
+ (tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f)))
+
+ (if (and
+ (not run-one)
+ (common:steps-can-proceed-given-status-sym rollup-status-sym)
+ (not (null? tal)))
+ (loop (car tal)
+ (cdr tal)
+ rollup-status-sym
+ saw-start-step-name-next)))))
+ (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
+
+ ;; Once done with step/steps update the test record
+ ;;
+ (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
+ (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
+ ;; Am I completed?
+ (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
+ (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
+ ;; "COMPLETED"
+ ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
+ )
+ (new-status rollup-status-string)
+ ) ;; (db:test-get-status testinfo)))
+ (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
+ (tests:test-set-status! run-id test-id
+ (if do-update-test-state-status new-state orig-test-state)
+ (if do-update-test-state-status new-status orig-test-status)
+ (args:get-arg "-m") #f)
+ ;; need to update the top test record if PASS or FAIL and this is a subtest
+ (if (and (not (equal? item-path "")) do-update-test-state-status)
+ (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f))))
+ ;; for automated creation of the rollup html file this is a good place...
+ (if (not (equal? item-path ""))
+ (tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no
+ )))
+ ;;(pop-directory)
+ rollup-status-string))
+
+(define (ezsteps:spawn-run-from testdat start-step-name run-one)
+ (thread-start!
+ (make-thread
+ (lambda ()
+ (ezsteps:run-from testdat start-step-name run-one))
+ (conc "ezstep run single step " start-step-name " run-one="run-one)))
+ )
+
+
+)
Index: keysmod.scm
==================================================================
--- keysmod.scm
+++ keysmod.scm
@@ -19,12 +19,12 @@
;;======================================================================
(declare (unit keysmod))
(declare (uses mtargs))
(declare (uses debugprint))
-(declare (uses configfmod))
-(declare (uses commonmod))
+;; (declare (uses configfmod))
+;; (declare (uses commonmod))
(module keysmod
*
(import scheme
@@ -64,11 +64,11 @@
stack
typed-records
z3
configfmod
- commonmod
+ ;; commonmod
)
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================
@@ -121,19 +121,7 @@
targlist)))
(map (lambda (key targ)
(list key targ))
keys targtweaked)))
-;;======================================================================
-;; config file related routines
-;;======================================================================
-
-(define keys:config-get-fields common:get-fields)
-(define (keys:make-key/field-string confdat)
- (let ((fields (configf:get-section confdat "fields")))
- (string-join
- (map (lambda (field)(conc (car field) " " (cadr field)))
- fields)
- ",")))
-
)
Index: launchmod.scm
==================================================================
--- launchmod.scm
+++ launchmod.scm
@@ -17,21 +17,25 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit launchmod))
-(declare (uses debugprint))
+
(declare (uses commonmod))
(declare (uses configfmod))
-(declare (uses mtargs))
-(declare (uses mtver))
(declare (uses csv-xml))
+(declare (uses dbmod))
+(declare (uses debugprint))
(declare (uses keysmod))
+(declare (uses mtargs))
(declare (uses mtmod))
+(declare (uses mtver))
(declare (uses processmod))
-(declare (uses dbmod))
-(declare (uses runsmod))
+(declare (uses rmtmod))
+(declare (uses servermod))
+(declare (uses testsmod))
+(declare (uses ezstepsmod))
(module launchmod
*
(import scheme
@@ -46,10 +50,11 @@
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
+ chicken.process.signal
chicken.sort
chicken.string
chicken.time
chicken.time.posix
@@ -62,25 +67,39 @@
srfi-1
srfi-13
srfi-18
srfi-69
stack
+ system-information
+
typed-records
z3
-
- (prefix mtargs args:)
- commonmod
- configfmod
- debugprint
- keysmod
- mtmod
- mtver
- processmod
- dbmod
- runsmod
+ sxml-serializer
+ sxml-modifications
+ (prefix sxml-modifications sxml-)
+ sxml-transforms
+ chicken.bitwise
)
+
+(import (prefix mtargs args:))
+(import commonmod)
+(import configfmod)
+(import dbmod)
+(import debugprint)
+(import keysmod)
+(import mtmod)
+(import mtver)
+(import processmod)
+(import rmtmod)
+(import servermod)
+(import testsmod)
+(import ezstepsmod)
+
+(include "db_records.scm")
+(include "key_records.scm")
+
;;======================================================================
;; ezsteps
;;======================================================================
;; ezsteps were going to be coded as
@@ -342,11 +361,11 @@
(debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2)
(tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt
)))
(mutex-unlock! m)
;; no point in sticking around. Exit now. But run end of run before exiting?
- (launch:end-of-run-check run-id)
+ (runs:end-of-run-check run-id)
(exit)))
(if (hash-table-ref/default misc-flags 'keep-going #f)
(begin
(thread-sleep! 3) ;; (+ 3 (pseudo-random-integer 6))) ;; add some jitter to the call home time to spread out the db accesses
(if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
@@ -749,43 +768,19 @@
(tests:summarize-test run-id test-id) ;; don't force - just update if no
;; Leave a .final-status file for the top level test
(tests:save-final-status run-id test-id)
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
(mutex-unlock! m)
- (launch:end-of-run-check run-id )
+ (runs:end-of-run-check run-id )
(debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(if (not (launch:einf-exit-status exit-info))
(exit 4))))
)))
;; launch:end-of-run-check moved to runs:end-of-run-check
-
-(define (launch:kill-tests-if-dead run-id)
- (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
- (let loop ((running-test (car running-tests))
- (tal (cdr running-tests))
- (kill-cnt 0))
- (let* ((test-name (vector-ref running-test 2))
- (item-path (vector-ref running-test 11))
- (test-id (vector-ref running-test 0))
- (host (vector-ref running-test 6))
- (pid (rmt:test-get-top-process-pid run-id test-id))
- (event-time (vector-ref running-test 5))
- (duration (vector-ref running-test 12))
- (flag 0)
- (curr-time (current-seconds)))
- (if (and (< (+ event-time duration 600) curr-time) (not (launch:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed
- (begin
- (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed")
- (set! flag 1)
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f)))
- (if (not (null? tal))
- (loop (car tal) (cdr tal) (+ kill-cnt flag))
- (+ kill-cnt flag))))))
-
;; DO NOT USE - caching of configs is handled in launch:setup now.
;;
(define (launch:cache-config)
;; if we have a linktree and -runtests and -target and the directory exists dump the config
;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
@@ -1602,9 +1597,705 @@
;; when the process exits look at the db, if still RUNNING after 10 seconds set
;; state/status appropriately
(process-wait pid)))
+(define (runs:remove-test-directory test mode) ;; remove-data-only)
+ (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree
+ (real-dir (if (common:file-exists? run-dir)
+ ;; (resolve-pathname run-dir)
+ (common:nice-path run-dir)
+ #f))
+ (clean-mode (or mode 'remove-all))
+ (test-id (db:test-get-id test))
+ ;; (lock-key (conc "test-" test-id))
+ ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key))
+ ;; (expire-time (+ (current-seconds) 30))) ;; give up on getting the lock and steal it after 15 seconds
+ ;; (if (car lock)
+ ;; #t
+ ;; (if (> (current-seconds) expire-time)
+ ;; (begin
+ ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to clean test with id " test-id)
+ ;; (rmt:no-sync-del! lock-key) ;; destroy the lock
+ ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;;
+ ;; (begin
+ ;; (thread-sleep! 1)
+ ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))))
+ )
+ (case clean-mode
+ ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
+ ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
+ ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
+ (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
+ (if (and real-dir
+ (> (string-length real-dir) 5)
+ (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
+ (let* ((realpath (realpath run-dir)))
+ (debug:print-info 1 *default-log-port* "Recursively removing " realpath)
+ (if (common:file-exists? realpath)
+ (runs:safe-delete-test-dir realpath)
+ (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
+ (if real-dir
+ (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
+ (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
+ (if (symbolic-link? run-dir)
+ (begin
+ (debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
+ (handle-exceptions
+ exn
+ (debug:print-error 0 *default-log-port* " Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn)
+ (delete-file run-dir)))
+ (if (directory? run-dir)
+ (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
+ (debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty")
+ (handle-exceptions
+ exn
+ (debug:print-error 0 *default-log-port* " Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn)
+ (delete-directory run-dir)))
+ (if (and run-dir
+ (not (member run-dir (list "n/a" "/tmp/badname"))))
+ (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
+ (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
+ ))
+ ;; Only delete the records *after* removing the directory. If things fail we have a record
+ (case clean-mode
+ ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f))
+ ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
+ (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))
+ ;; (rmt:no-sync-del! lock-key)
+ ))
+
+(define (runs:recursive-delete-with-error-msg real-dir)
+ (if (> (system (conc "rm -rf " real-dir)) 0)
+ (begin
+ ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time
+ (system (conc "chmod -R a+rwx " real-dir))
+ (if (> (system (conc "rm -rf " real-dir)) 0)
+ (debug:print-error 0 *default-log-port* "There was a problem removing " real-dir " with rm -f")))))
+
+(define (runs:safe-delete-test-dir real-dir)
+ ;; first delete all sub-directories
+ (directory-fold
+ (lambda (f x)
+ (let ((fullname (conc real-dir "/" f)))
+ (if (directory? fullname)(runs:recursive-delete-with-error-msg fullname)))
+ (+ 1 x))
+ 0 real-dir)
+ ;; then files other than *testdat.db*
+ (directory-fold
+ (lambda (f x)
+ (let ((fullname (conc real-dir "/" f)))
+ (if (not (string-search (regexp "testdat.db") f))
+ (runs:recursive-delete-with-error-msg fullname)))
+ (+ 1 x))
+ 0 real-dir #t)
+ ;; then the entire directory
+ (runs:recursive-delete-with-error-msg real-dir))
+
+
+;;======================================================================
+;; ideally put all this info into the db, no need to preserve it across moving homehost
+;;
+;; return list of
+;; ( reachable? cpuload update-time )
+(define (common:get-host-info hostname)
+ (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
+ (load (car loadinfo))
+ (load-sample-time (cdr loadinfo))
+ (load-sample-age (- (current-seconds) load-sample-time))
+ (loadinfo-timeout-seconds 6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
+ (host-last-update-timeout-seconds 4)
+ (host-rec (hash-table-ref/default *host-loads* hostname #f))
+ )
+ (cond
+ ((< load-sample-age loadinfo-timeout-seconds)
+ (list #t
+ load-sample-time
+ load))
+ ((and host-rec
+ (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
+ (list #t
+ (host-last-update host-rec)
+ (host-last-cpuload host-rec )))
+ ((common:unix-ping hostname)
+ (list #t
+ (current-seconds)
+ (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
+ (else
+ (list #f 0 -1) ;; bad host, don't use!
+ ))))
+
+;;======================================================================
+;; see defstruct host at top of file.
+;; host: reachable last-update last-used last-cpuload
+;;
+(define (common:update-host-loads-table hosts-raw)
+ (let* ((hosts (filter (lambda (x)
+ (string-match (regexp "^\\S+$") x))
+ hosts-raw)))
+ (for-each
+ (lambda (hostname)
+ (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+ (if h
+ h
+ (let ((h (make-host)))
+ (hash-table-set! *host-loads* hostname h)
+ h))))
+ (host-info (common:get-host-info hostname))
+ (is-reachable (car host-info))
+ (last-reached-time (cadr host-info))
+ (load (caddr host-info)))
+ (host-reachable-set! rec is-reachable)
+ (host-last-update-set! rec last-reached-time)
+ (host-last-cpuload-set! rec load)))
+ hosts)))
+
+
+;;======================================================================
+;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
+;;======================================================================
+;;
+;; [hosts]
+;; arm cubie01 cubie02
+;; x86_64 zeus xena myth01
+;; allhosts #{g hosts arm} #{g hosts x86_64}
+;;
+;; [host-types]
+;; general #MTLOWESTLOAD #{g hosts allhosts}
+;; arm #MTLOWESTLOAD #{g hosts arm}
+;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
+;;
+;; [host-rules]
+;; # maxnload => max normalized load
+;; # maxnjobs => max jobs per cpu
+;; # maxjobrate => max jobs per second
+;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1
+;;
+;; [launchers]
+;; envsetup general
+;; xor/%/n 4C16G
+;; % nbgeneral
+;;
+;; [jobtools]
+;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
+;; flexi-launcher yes
+;; launcher nbfake
+;;
+(define (common:get-launcher configdat testname itempath)
+ (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
+ (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
+ (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
+ (let* ((launchers (hash-table-ref/default configdat "launchers" '())))
+ (if (null? launchers)
+ fallback-launcher
+ (let loop ((hed (car launchers))
+ (tal (cdr launchers)))
+ (let ((patt (car hed))
+ (host-type (cadr hed)))
+ (if (tests:match patt testname itempath)
+ (begin
+ (debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
+ (let ((launcher (configf:lookup configdat "host-types" host-type)))
+ (if launcher
+ (let* ((launcher-parts (string-split launcher))
+ (launcher-exe (car launcher-parts)))
+ (if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
+ (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
+ (count 100))
+ (if targ-host
+ (conc "remrun " targ-host)
+ (if (> count 0)
+ (begin
+ (debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
+ (thread-sleep! (- 101 count))
+ (host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
+ (- count 1)))
+ (begin
+ (debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
+ (exit)))))
+ launcher))
+ (begin
+ (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
+ (if (null? tal)
+ fallback-launcher
+ (loop (car tal)(cdr tal)))))))
+ ;; no match, try again
+ (if (null? tal)
+ fallback-launcher
+ (loop (car tal)(cdr tal))))))))
+ fallback-launcher)))
+
+;;======================================================================
+;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
+;; [host-rules] section.
+;;
+(define (common:get-least-loaded-host hosts-raw host-type configdat)
+ (let* ((rdat (configf:lookup configdat "host-rules" host-type))
+ (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate
+ (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
+ (maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
+ (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
+ (hosts (filter (lambda (x)
+ (string-match (regexp "^\\S+$") x))
+ hosts-raw))
+ ;; (best-host #f)
+ (get-rec (lambda (hostname)
+ ;; (print "get-rec hostname=" hostname)
+ (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+ (if h
+ h
+ (let ((h (make-host)))
+ (hash-table-set! *host-loads* hostname h)
+ h)))))
+ (best-load 99999)
+ (curr-time (current-seconds))
+ (get-hosts-sorted (lambda (hosts)
+ (sort hosts (lambda (a b)
+ (let ((a-rec (get-rec a))
+ (b-rec (get-rec b)))
+ ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
+ ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
+ (< (host-last-used a-rec)
+ (host-last-used b-rec))))))))
+ (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
+ (if (null? hosts)
+ #f ;; no hosts to select from. All done and giving up now.
+ (let ((hosts-sorted (get-hosts-sorted hosts)))
+ (common:update-host-loads-table hosts)
+ (let loop ((hostname (car hosts-sorted))
+ (tal (cdr hosts-sorted))
+ (best-host #f))
+ (let* ((rec (get-rec hostname))
+ (reachable (host-reachable rec))
+ (load (host-last-cpuload rec))
+ (last-used (host-last-used rec))
+ (delta (- curr-time last-used))
+ (job-rate (if (> delta 0)
+ (/ 1 delta)
+ 999)) ;; jobs per second
+ (new-best
+ (cond
+ ((not reachable)
+ (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
+ best-host)
+ ((and (< load maxnload) ;; load is acceptable
+ (< job-rate maxjobrate)) ;; job rate is acceptable
+ (set! best-load load)
+ hostname)
+ (else best-host))))
+ (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
+ (if new-best
+ (begin ;; found a host, return it
+ (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
+ (host-last-used-set! rec curr-time)
+ new-best)
+ (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))
+
+
+;; Spec for End of test
+;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup
+;; At transition to run COMPLETED/X do hooks
+;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND
+;; we can prove the process is not alive (ssh host pstree -A pid)
+;; if dead safe to mark the test as killed in the db
+;; State/status table
+;; new
+;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup
+;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na
+;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED
+;; 0 RUNNING ==> this is actually the first condition, should not get here
+
+(define (runs:end-of-run-check run-id )
+ (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
+ (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
+ (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
+ (current-state (rmt:get-run-state run-id))
+ (current-status (rmt:get-run-status run-id)))
+ ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing
+ (debug:print 0 *default-log-port* "Running test cnt :" running-cnt)
+ (rmt:set-state-status-and-roll-up-run run-id current-state current-status)
+ (runs:update-junit-test-reporter-xml run-id)
+ (cond
+ ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
+ (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
+ (begin
+ (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id)))
+ (debug:print 0 *default-log-port* "End of Run Detected.")
+ (rmt:set-var (conc "end-of-run-" run-id) "yes")
+ ;(thread-sleep! 10)
+ (runs:run-post-hook run-id)
+ (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id)))
+ (common:simple-unlock (conc "endOfRun" run-id)))
+ (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id)))))
+ ((> running-cnt 3)
+ (debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
+ ((> running-cnt 0)
+ (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
+ (let ((kill-cnt (launch:kill-tests-if-dead run-id)))
+ (if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
+ (runs:end-of-run-check run-id)))) ;;todo
+ (else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt)
+ (let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
+ (if (> (length not-completed-tests) 0)
+ (let loop ((running-test (car not-completed-tests))
+ (tal (cdr not-completed-tests)))
+ (let* ((test-name (vector-ref running-test 2))
+ (item-path (vector-ref running-test 11)))
+ (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
+ (if (not (null? tal))
+ (loop (car tal) (cdr tal)))))))))))
+
+(define (runs:find-and-mark-incomplete-and-check-end-of-run run-id ovr-deadtime)
+ (rmt:find-and-mark-incomplete run-id ovr-deadtime)
+ (runs:end-of-run-check run-id))
+
+
+
+(define (launch:kill-tests-if-dead run-id)
+ (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
+ (let loop ((running-test (car running-tests))
+ (tal (cdr running-tests))
+ (kill-cnt 0))
+ (let* ((test-name (vector-ref running-test 2))
+ (item-path (vector-ref running-test 11))
+ (test-id (vector-ref running-test 0))
+ (host (vector-ref running-test 6))
+ (pid (rmt:test-get-top-process-pid run-id test-id))
+ (event-time (vector-ref running-test 5))
+ (duration (vector-ref running-test 12))
+ (flag 0)
+ (curr-time (current-seconds)))
+ (if (and (< (+ event-time duration 600) curr-time) (not (launch:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed
+ (begin
+ (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed")
+ (set! flag 1)
+ (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f)))
+ (if (not (null? tal))
+ (loop (car tal) (cdr tal) (+ kill-cnt flag))
+ (+ kill-cnt flag))))))
+
+
+(define (runs:run-post-hook run-id)
+ (let* ((run-post-hook (configf:lookup *configdat* "runs" "post-hook"))
+ (existing-tests (if run-post-hook
+ (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
+ #f #f ;; offset limit
+ #f ;; not-in
+ #f ;; sort-by
+ #f ;; sort-order
+ #f ;; get full data (not 'shortlist)
+ 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
+ 'dashboard)
+ '()))
+ (log-dir (conc *toppath* "/logs"))
+ (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
+ (full-log-fname (conc log-dir "/" log-file)))
+ (if run-post-hook
+ ;; (if (null? existing-tests)
+ ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
+ (let* ((use-log-dir (if (not (directory-exists? log-dir))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn)
+ #f)
+ (create-directory log-dir #t)
+ #t)
+ #t))
+ (start-time (current-seconds))
+ (actual-logf (if use-log-dir full-log-fname log-file)))
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain *default-log-port*)
+ (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
+ (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
+ (system (conc run-post-hook " >> " actual-logf " 2>&1"))
+ (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
+
+
+(define (runs:rerun-hook test-id new-test-path testdat rerunlst)
+ (let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook"))
+ (log-dir (conc *toppath* "/reruns/logs"))
+ (target (getenv "MT_TARGET"))
+ (runname (common:args-get-runname))
+ (rundir (db:test-get-rundir testdat))
+ (tarfiledir (conc *toppath* "/reruns"))
+ (status (db:test-get-status testdat))
+ (comment (conc "\"" (db:test-get-comment testdat) "\"" ))
+ (testname (db:test-get-testname testdat))
+ (itempath (db:test-get-item-path testdat))
+ (file-body (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "")))
+ (log-file (conc file-body ".log"))
+ ;; (log-file (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".log"))
+ (full-log-fname (conc log-dir "/" log-file))
+ (tarfilename (conc file-body ".tar"))
+ ;; (tarfilename (conc status "." (string-translate target "/" "-") "." runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".tar"))
+ )
+ (if rerun-hook
+ (let* ((use-log-dir (if (not (directory-exists? log-dir))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn)
+ #f)
+ (create-directory log-dir #t)
+ #t)
+ #t))
+ (start-time (current-seconds))
+ (actual-logf (if use-log-dir full-log-fname log-file))
+ (sys-call-text (conc rerun-hook " " tarfilename " " rundir " " actual-logf " " runname " " tarfiledir " " status " " target " " comment " " testname " " itempath " >> " actual-logf " 2>&1"))
+ )
+ (debug:print 2 *default-log-port* "Found rerun-hook in config:" rerun-hook)
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain *default-log-port*)
+ (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (debug:print 0 *default-log-port* "ERROR: failed to run rerun-hook " rerun-hook ", check the log " log-file))
+ (debug:print-info 0 *default-log-port* "running rerun-hook: \"" rerun-hook "\", log is " actual-logf)
+ ;; call the hook
+ (debug:print-info 0 *default-log-port* "Calling rerun-hook for " test-id new-test-path testdat rerunlst)
+ (debug:print-info 0 *default-log-port* "rerun hook: " rerun-hook)
+ (debug:print-info 0 *default-log-port* "tarfilename: " tarfilename)
+ (debug:print-info 0 *default-log-port* "rundir: " rundir)
+ (debug:print-info 0 *default-log-port* "actual-logf: " actual-logf)
+ (debug:print-info 0 *default-log-port* "runname: " runname)
+ (debug:print-info 0 *default-log-port* "sys-call-text: " sys-call-text)
+ (system sys-call-text)
+ (debug:print-info 0 *default-log-port* "rerun-hook \"" rerun-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
+
+
+(define (runs:update-junit-test-reporter-xml run-id)
+ (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
+ (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir"))
+ (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
+ (if junit-test-report-dir
+ junit-test-report-dir
+ (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
+ #f))
+ (xml-ts-name (if xml-dir
+ (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
+ #f))
+ (keyname (if xml-ts-name (common:get-signature xml-ts-name) #f))
+ (xml-path (if xml-dir
+ (conc xml-dir "/" keyname ".xml")
+ #f))
+
+ (test-data (if xml-dir
+ (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
+ #f #f ;; offset limit
+ #f ;; not-in
+ #f ;; sort-by
+ #f ;; sort-order
+ #f ;; get full data (not 'shortlist)
+ 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
+ #f)
+ '()))
+ (tests-count (if xml-dir (length test-data) #f)))
+ (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
+ (begin
+ ;((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count)))) doc)
+
+ (let loop ((test (car test-data))
+ (tail (cdr test-data))
+ (doc doc-template)
+ (fail-cnt 0)
+ (error-cnt 0))
+ (let* ((test-name (vector-ref test 2))
+ (test-itempath (vector-ref test 11))
+ (tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
+ (test-state (vector-ref test 3))
+ (comment (vector-ref test 14))
+ (test-status (vector-ref test 4))
+ (exc-msg (conc "No bucket for State " test-state " Status " test-status))
+ (new-doc (cond
+ ((member test-state (list "RUNNING" ))
+ ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
+ ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
+ ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
+ ((member test-status (list "PASS" "WARN" "WAIVED"))
+ ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
+ ((member test-status (list "FAIL" "CHECK"))
+ ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
+ ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
+ ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
+ ((member test-status (list "SKIP"))
+ ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
+ (else
+ (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
+ ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
+ (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
+ (+ error-cnt 1)
+ error-cnt))
+ (new-fail-cnt (if (member test-status (list "FAIL" "CHECK"))
+ (+ fail-cnt 1)
+ fail-cnt)))
+ (if (null? tail)
+ (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
+ (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
+ (handle-exceptions
+ exn
+ (let* ((msg ((condition-property-accessor 'exn 'message) exn)))
+ (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))
+
+ (if (not (file-exists? xml-dir))
+ (create-directory xml-dir #t))
+ (if (not (rmt:no-sync-get/default keyname #f))
+ (begin
+ (rmt:no-sync-set keyname "on")
+ (debug:print 0 *default-log-port* "creating xml at " xml-path)
+ (with-output-to-file xml-path
+ (lambda ()
+ (print (sxml-serializer#serialize-sxml final-doc ns-prefixes: (list (cons 'gnm "http://foo"))))))
+ (rmt:no-sync-del! keyname))
+ (debug:print 0 *default-log-port* "Could not get the lock. Skip writing the xml file."))))
+ (loop (car tail) (cdr tail) new-doc new-fail-cnt new-error-cnt))))))))
+
+(define doc-template
+ '(*TOP*
+ (*PI* xml "version='1.0'")
+ (testsuite)))
+
+(define (set-item-env-vars itemdat)
+ (for-each (lambda (item)
+ (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
+ (setenv (car item) (cadr item)))
+ itemdat))
+
+;; set up needed environment variables given a run-id and optionally a target, itempath etc.
+;;
+(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
+ ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
+ (let* ((target (or intarget
+ (common:args-get-target)
+ (get-environment-variable "MT_TARGET")))
+ (keys (if inkeys inkeys (common:get-fields *configdat*) #;(rmt:get-keys)))
+ (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
+ (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
+ (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (if testname (setenv "MT_TEST_NAME" testname))
+ (if itempath (setenv "MT_ITEMPATH" itempath))
+
+ ;; get the info from the db and put it in the cache
+ (if link-tree
+ (setenv "MT_LINKTREE" link-tree)
+ (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
+ (if (not vals)
+ (let ((ht (make-hash-table)))
+ (hash-table-set! *env-vars-by-run-id* run-id ht)
+ (set! vals ht)
+ (for-each
+ (lambda (key)
+ (hash-table-set! vals (car key) (cadr key)))
+ keyvals)))
+ ;; from the cached data set the vars
+
+ (hash-table-for-each
+ vals
+ (lambda (key val)
+ (debug:print 2 *default-log-port* "setenv " key " " val)
+ (safe-setenv key val)))
+ ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1")
+ ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals))
+
+ (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
+ ;; we had a case where there was an exception generated by the hash-table-ref
+ ;; due to *configdat* being #f Adding a handle and exit
+ (let fatal-loop ((count 0))
+ (handle-exceptions
+ exn
+ (let ((call-chain (get-call-chain))
+ (msg ((condition-property-accessor 'exn 'message) exn)))
+ (if (< count 5)
+ (begin ;; this call is colliding, do some crude stuff to fix it.
+ (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count
+ ", exn=" exn)
+ (launch:setup force-reread: #t)
+ (fatal-loop (+ count 1)))
+ (begin
+ (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count
+ " times. Message: " msg)
+ (debug:print 0 *default-log-port* "Call chain:")
+ (with-output-to-port *default-log-port*
+
+ (lambda ()
+ (print "*configdat* is >>"*configdat*"<<")
+ (pp *configdat*)
+ (pp call-chain)))
+
+ (exit 1))))
+ ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5")
+ (when (or (not *configdat*) (not (hash-table? *configdat*)))
+ (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.")
+ ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.")
+ (thread-sleep! 2) ;; assuming nfs lag.
+ (launch:setup force-reread: #t))
+ (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
+ ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
+ ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
+ (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
+ (if runname
+ (setenv "MT_RUNNAME" runname)
+ (debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ ;; if a testname and itempath are available set the remaining appropriate variables
+ (if testname (setenv "MT_TEST_NAME" testname))
+ (if itempath (setenv "MT_ITEMPATH" itempath))
+ ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3")
+ (if (and testname link-tree)
+ (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/"
+ (getenv "MT_TARGET") "/"
+ (getenv "MT_RUNNAME") "/"
+ (getenv "MT_TEST_NAME")
+ (if (and itempath
+ (not (equal? itempath "")))
+ (conc "/" itempath)
+ ""))))))
+
+;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
+;;
+(define (full-runconfigs-read)
+ ;; in the envprocessing branch the below code replaces the further below code
+ ;; (if (eq? *configstatus* 'fulldata)
+ ;; *runconfigdat*
+ ;; (begin
+ ;; (launch:setup)
+ ;; *runconfigdat*)))
+ (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
+ (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
+ #f))
+ (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
+ (if (and cfgf
+ (common:file-exists? cfgf)
+ (file-writable? cfgf)
+ (common:use-cache?))
+ (configf:read-alist cfgf)
+ (let* ((keys (common:get-fields cfgf)) ;; (rmt:get-keys))
+ (target (common:args-get-target))
+ (key-vals (if target (keys:target->keyval keys target) #f))
+ (sections (if target (list "default" target) #f))
+ (data (begin
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (if key-vals
+ (for-each (lambda (kt)
+ (setenv (car kt) (cadr kt)))
+ key-vals))
+ ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
+ (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
+ (if (and rundir ;; have all needed variabless
+ (directory-exists? rundir)
+ (file-writable? rundir))
+ (begin
+ (if (not (common:in-running-test?))
+ (configf:write-alist data cfgf))
+ ;; force re-read of megatest.config - this resolves circular references between megatest.config
+ (launch:setup force-reread: #t)
+ ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
+ )) ;; we can safely cache megatest.config since we have a valid runconfig
+ data))))
+
)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1140,54 +1140,12 @@
((json)
(json-write targets))
(else
(debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
(set! *didsomething* #t))))
-
-
-;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
-;;
-(define (full-runconfigs-read)
-;; in the envprocessing branch the below code replaces the further below code
-;; (if (eq? *configstatus* 'fulldata)
-;; *runconfigdat*
-;; (begin
-;; (launch:setup)
-;; *runconfigdat*)))
- (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
- (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
- #f))
- (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
- (if (and cfgf
- (common:file-exists? cfgf)
- (file-writable? cfgf)
- (common:use-cache?))
- (configf:read-alist cfgf)
- (let* ((keys (rmt:get-keys))
- (target (common:args-get-target))
- (key-vals (if target (keys:target->keyval keys target) #f))
- (sections (if target (list "default" target) #f))
- (data (begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (if key-vals
- (for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
- key-vals))
- ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
- (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
- (if (and rundir ;; have all needed variabless
- (directory-exists? rundir)
- (file-writable? rundir))
- (begin
- (if (not (common:in-running-test?))
- (configf:write-alist data cfgf))
- ;; force re-read of megatest.config - this resolves circular references between megatest.config
- (launch:setup force-reread: #t)
- ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
- )) ;; we can safely cache megatest.config since we have a valid runconfig
- data))))
-
+
+
(if (args:get-arg "-show-runconfig")
(let ((tl (launch:setup)))
(push-directory *toppath*)
(let ((data (full-runconfigs-read)))
;; keep this one local
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -133,50 +133,5 @@
(begin
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
-;;======================================================================
-;; S T A T E A N D S T A T U S F O R T E S T S
-;;======================================================================
-
-;; speed up for common cases with a little logic
-(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
- (if (not (and run-id test-id))
- (begin
- (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
- (print-call-chain (current-error-port))
- #f)
- (begin
- ;; cond
- ;; ((and newstate newstatus newcomment)
- ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
- ;; ((and newstate newstatus)
- ;; (rmt:general-call 'state-status run-id newstate newstatus test-id))
- ;; (else
- ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
- ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
- ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
- (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)
- ;; (mt:process-triggers run-id test-id newstate newstatus)
- #t)))
-
-
-(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment)
- (let* ((test-vec (rmt:get-testinfo-state-status run-id test-id))
- (state (vector-ref test-vec 3)))
- (if (equal? state "COMPLETED")
- #t
- (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment))))
-
-
-(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
- ;(let ((test-id (rmt:get-test-id run-id test-name item-path)))
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment)
- ;; (mt:process-triggers run-id test-id new-state new-status)
- #t);)
- ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))
-
-(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment)
- (let ((test-id (rmt:get-test-id run-id test-name item-path)))
- (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment)))
-
ADDED portloggermod.scm
Index: portloggermod.scm
==================================================================
--- /dev/null
+++ portloggermod.scm
@@ -0,0 +1,237 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit portloggermod))
+(declare (uses debugprint))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses tasksmod))
+(declare (uses dbmod))
+
+(module portloggermod
+ *
+
+(import scheme
+ (prefix sqlite3 sqlite3:)
+ chicken.base
+ chicken.condition
+ chicken.random
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ (prefix base64 base64:)
+ csv-xml
+ directory-utils
+ matchable
+ regex
+ s11n
+ srfi-1
+ srfi-13
+ srfi-18
+ srfi-69
+ stack
+ system-information
+ typed-records
+ z3
+
+ (prefix mtargs args:)
+ commonmod
+ configfmod
+ debugprint
+ tasksmod
+ dbmod
+
+ )
+;; lsof -i
+
+(define (portlogger:open-db fname)
+ (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
+ (exists (common:file-exists? fname))
+ (db (if avail
+ (sqlite3:open-database fname)
+ (begin
+ (system (conc "rm -f " fname))
+ (sqlite3:open-database fname))))
+ (handler (sqlite3:make-busy-timeout 136000))
+ (canwrite (file-writable? fname)))
+ ;; (db-init (lambda ()
+ ;; (sqlite3:execute
+ ;; db
+ ;; "CREATE TABLE IF NOT EXISTS ports (
+ ;; port INTEGER PRIMARY KEY,
+ ;; state TEXT DEFAULT 'not-used',
+ ;; fail_count INTEGER DEFAULT 0,
+ ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );"))))
+ (sqlite3:set-busy-handler! db handler)
+ (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
+ ;; (if (not exists) ;; needed with IF NOT EXISTS?
+ (sqlite3:execute
+ db
+ "CREATE TABLE IF NOT EXISTS ports (
+ port INTEGER PRIMARY KEY,
+ state TEXT DEFAULT 'not-used',
+ fail_count INTEGER DEFAULT 0,
+ update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
+ db))
+
+(define (portlogger:open-run-close proc . params)
+ (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db"))
+ (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
+ (handle-exceptions
+ exn
+ (begin
+ ;; (release-dot-lock fname)
+ (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (if (common:file-exists? fname)(delete-file fname)) ;; brutally get rid of it
+ (print-call-chain (current-error-port)))
+ (let* (;; (lock (obtain-dot-lock fname 2 9 10))
+ (db (portlogger:open-db fname))
+ (res (apply proc db params)))
+ (sqlite3:finalize! db)
+ ;; (release-dot-lock fname)
+ res))))
+
+;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
+(define (portlogger:take-port db portnum)
+ (let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);"))
+ (qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;"))
+ (qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;"))
+ (res (sqlite3:with-transaction
+ db
+ (lambda ()
+ ;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;")
+ (let* ((curr #f)
+ (res #f))
+ (set! curr (sqlite3:fold-row
+ (lambda (var curr)
+ (or curr var curr))
+ "not-tried"
+ qry3
+ portnum))
+ ;; (print "curr=" curr)
+ (set! res (case (string->symbol curr)
+ ((released) (sqlite3:execute qry2 "taken" portnum) 'taken)
+ ((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken)
+ ((taken) 'already-taken)
+ ((failed) 'failed)
+ (else 'error)))
+ ;; (print "res=" res)
+ res)))))
+ (sqlite3:finalize! qry1)
+ (sqlite3:finalize! qry2)
+ (sqlite3:finalize! qry3)
+ res))
+
+(define (portlogger:get-prev-used-port db)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* "Continuing anyway.")
+ #f)
+ (sqlite3:fold-row
+ (lambda (var curr)
+ (or curr var curr))
+ #f
+ db
+ "SELECT (port) FROM ports WHERE state='released' LIMIT 1;")))
+
+(define (portlogger:find-port db)
+ (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
+ (if (and val
+ (string->number val))
+ (string->number val)
+ 32768)))
+ (portnum (or (portlogger:get-prev-used-port db)
+ (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
+ (pseudo-random-integer (- 64000 lowport))))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* "Continuing anyway."))
+ (portlogger:take-port db portnum))
+ portnum))
+
+;; set port to "released", "failed" etc.
+;;
+(define (portlogger:set-port db portnum value)
+ (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum))
+
+;; set port to failed (attempted to take but got error)
+;;
+(define (portlogger:set-failed db portnum)
+ (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum))
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+(define (portlogger:main . args)
+ (let* ((dbfname (conc "/tmp/." (current-user-name) "-portlogger.db"))
+ (db (portlogger:open-db dbfname))
+ (numargs (length args))
+ (result
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+ (print-call-chain (current-error-port))
+ #f)
+ (case (string->symbol (car args)) ;; commands with two or more params
+ ((take)(portlogger:take-port db (string->number (cadr args))))
+ ((find)(portlogger:find-port db))
+ ((set) (let ((port (cadr args))
+ (state (caddr args)))
+ (portlogger:set-port db
+ (if (number? port) port (string->number port))
+ state)
+ state))
+ ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)))))
+ (sqlite3:finalize! db)
+ result))
+
+;; (print (apply portlogger:main (cdr (argv))))
+
+
+)
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -22,10 +22,17 @@
(declare (uses commonmod))
(declare (uses apimod))
(declare (uses itemsmod))
(declare (uses debugprint))
(declare (uses mtver))
+(declare (uses tasksmod))
+(declare (uses pgdb))
+(declare (uses mtargs))
+(declare (uses dbmod))
+(declare (uses http-transportmod))
+(declare (uses servermod))
+(declare (uses clientmod))
(module rmtmod
*
(import scheme
@@ -34,28 +41,40 @@
chicken.base
chicken.condition
chicken.sort
chicken.time
chicken.base
+ chicken.file
+ chicken.format
(prefix sqlite3 sqlite3:)
typed-records
srfi-1
+ srfi-13
srfi-18
srfi-69
commonmod
apimod
itemsmod
debugprint
mtver
+ tasksmod
+ pgdb
+ (prefix mtargs args:)
+ dbmod
+ http-transportmod
+ servermod
+ clientmod
)
(defstruct alldat
(areapath #f)
(ulexdat #f)
)
+
+(include "db_records.scm")
;;======================================================================
;; return the handle struct for sending queries to a specific database
;; - initializes the connection object if this is the first access
;; - finds the "captain" and asks who to talk to for the given dbfname
@@ -171,11 +190,11 @@
;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
;; ensure we have a record for our connection for given area
(if (not runremote) ;; can remove this one. should never get here.
(begin
- (set! *runremote* (make-init-remote))
+ (set! *runremote* (make-and-init-remote))
(let* ((server-info (remote-server-info *runremote*)))
(if server-info
(begin
(remote-server-url-set! *runremote* (server:record->url server-info))
(remote-server-id-set! *runremote* (server:record->id server-info)))))
@@ -252,11 +271,11 @@
;; on homehost and this is a write, we already have a server, but server has died
((and (cdr (remote-hh-dat runremote)) ;; on homehost
(not (member cmd api:read-only-queries)) ;; this is a write
(remote-server-url runremote) ;; have a server
(not (server:ping (remote-server-url runremote) (remote-server-id runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
- (set! *runremote* (make-init-remote))
+ (set! *runremote* (make-and-init-remote))
(let* ((server-info (remote-server-info *runremote*)))
(if server-info
(begin
(remote-server-url-set! *runremote* (server:record->url server-info))
(remote-server-id-set! *runremote* (server:record->id server-info)))))
@@ -332,32 +351,10 @@
;;DOT }
;; bunch of small functions factored out of send-receive to make debug easier
;;
-(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
- ;; (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9")
- ;; (mutex-lock! *rmt-mutex*)
- (let* ((conninfo (remote-conndat runremote))
- (dat-in (case (remote-transport runremote)
- ((http) (condition-case ;; handling here has
- ;; caused a lot of
- ;; problems. However it
- ;; is needed to deal with
- ;; attemtped
- ;; communication to
- ;; servers that have gone
- ;; away
- (http-transport:client-api-send-receive 0 conninfo cmd params)
- ((servermismatch) (vector #f "Server id mismatch" ))
- ((commfail)(vector #f "communications fail"))
- ((exn)(vector #f "other fail" (print-call-chain)))))
- (else
- (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported")
- (exit))))
-
;; No Title
;; Error: (vector-ref) out of range
;; #(# (#("db.scm:3740: regex#regexp" #f #f) #("db.scm:3739: regex#string-substitute" #f #f) #("db.scm:3738: base64#base64-decode" #f #f) #("db.scm:3737: z3#z3:decode-buffer" #f #f) #("db.scm:3736: with-input-from-string" #f #f) #("db.scm:3741: s11n#deserialize" #f #f) #("api.scm:374: api:execute-requests" #f #f) #("api.scm:139: call-with-current-continuation" #f #f) #("api.scm:139: with-exception-handler" #f #f) #("api.scm:139: ##sys#call-with-values" #f #f) #("api.scm:158: string->symbol" #f #f) #("api.scm:160: current-milliseconds" #f #f) #("api.scm:161: dbr:dbstruct-read-only" #f #f) #("api.scm:139: k15" #f #f) #("api.scm:139: g19" #f #f) #("api.scm:142: get-call-chain" #f #f)) #("get-test-info-by-id" (1102 507299)))
;; 6
;;
@@ -376,10 +373,27 @@
;; rmt.scm:287: extras-transport-succeded <--
;; +-----------------------------------------------------------------------------+
;; | Exit Status : 70
;;
+(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
+ ;; (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9")
+ ;; (mutex-lock! *rmt-mutex*)
+ (let* ((conninfo (remote-conndat runremote))
+ (dat-in (condition-case ;; handling here has
+ ;; caused a lot of
+ ;; problems. However it
+ ;; is needed to deal with
+ ;; attemtped
+ ;; communication to
+ ;; servers that have gone
+ ;; away
+ (http-transport:client-api-send-receive 0 conninfo cmd params)
+ ((servermismatch) (vector #f "Server id mismatch" ))
+ ((commfail)(vector #f "communications fail"))
+ ((exn)(vector #f "other fail" (print-call-chain)))))
(dat (if (and (vector? dat-in) ;; ... check it is a correct size
(> (vector-length dat-in) 1))
dat-in
(vector #f (conc "communications fail (type 2), dat-in=" dat-in))))
(success (if (vector? dat) (vector-ref dat 0) #f))
@@ -1439,7 +1453,62 @@
(for-each
(lambda (run-id)
(debug:print-info 4 *default-log-port* "Check if run with " run-id " needs to be synced" )
(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
run-ids))
+
+;;======================================================================
+;; simple lock. improve and converge on this one.
+;;
+(define (common:simple-lock keyname)
+ (rmt:no-sync-get-lock keyname))
+
+(define (common:simple-unlock keyname #!key (force #f))
+ (rmt:no-sync-del! keyname))
+
+;;======================================================================
+;; S T A T E A N D S T A T U S F O R T E S T S
+;;======================================================================
+
+;; speed up for common cases with a little logic
+(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
+ (if (not (and run-id test-id))
+ (begin
+ (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
+ (print-call-chain (current-error-port))
+ #f)
+ (begin
+ ;; cond
+ ;; ((and newstate newstatus newcomment)
+ ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
+ ;; ((and newstate newstatus)
+ ;; (rmt:general-call 'state-status run-id newstate newstatus test-id))
+ ;; (else
+ ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
+ ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
+ ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
+ (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)
+ ;; (mt:process-triggers run-id test-id newstate newstatus)
+ #t)))
+
+
+(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment)
+ (let* ((test-vec (rmt:get-testinfo-state-status run-id test-id))
+ (state (vector-ref test-vec 3)))
+ (if (equal? state "COMPLETED")
+ #t
+ (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment))))
+
+
+(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
+ ;(let ((test-id (rmt:get-test-id run-id test-name item-path)))
+ (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment)
+ ;; (mt:process-triggers run-id test-id new-state new-status)
+ #t);)
+ ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))
+
+(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment)
+ (let ((test-id (rmt:get-test-id run-id test-name item-path)))
+ (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment)))
+
)
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -25,15 +25,10 @@
;; (declare (unit runconfig))
;; (declare (uses common))
;;
;; (include "common_records.scm")
-(define (runconfig:read fname target environ-patt)
- (let ((ht (make-hash-table)))
- (if target (hash-table-set! ht target '()))
- (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
-
;; NB// to process a runconfig ensure to use environ-patt with target!
;;
(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t))
(let* ((keys (map car keyvals))
(thekey (if keyvals
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -29,10 +29,12 @@
(declare (uses mtmod))
(declare (uses processmod))
(declare (uses dbmod))
(declare (uses rmtmod))
(declare (uses testsmod))
+(declare (uses tasksmod))
+(declare (uses archivemod))
(module runsmod
*
(import scheme
@@ -51,11 +53,13 @@
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
-
+ chicken.random
+ chicken.process.signal
+
(prefix base64 base64:)
csv-xml
directory-utils
matchable
regex
@@ -63,10 +67,11 @@
srfi-1
srfi-13
srfi-18
srfi-69
stack
+ sxml-modifications
system-information
typed-records
z3
(prefix mtargs args:)
@@ -78,12 +83,17 @@
mtver
processmod
dbmod
rmtmod
testsmod
+ tasksmod
+ archivemod
)
+
+(include "db_records.scm")
+
;; use this struct to facilitate refactoring
;;
(defstruct runs:dat
reglen regfull
@@ -181,140 +191,10 @@
(loop)))))
(let* ((done-time (current-seconds)))
(debug:print-info 0 *default-log-port* "DONE: rtime=" rtime ", elapsed time=" (- done-time startt)
", ratio=" (/ rtime (- done-time startt))))))
-(define (runs:get-mt-env-alist run-id runname target testname itempath)
- ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
- `(("MT_TEST_NAME" . ,testname)
-
- ("MT_ITEMPATH" . ,itempath)
-
- ("MT_TARGET" . ,target)
-
- ("MT_RUNNAME" . ,runname)
-
- ("MT_RUN_AREA_HOME" . ,*toppath*)
-
- ,@(let* ((link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
- (if link-tree
- (list (cons "MT_LINKTREE" link-tree)
-
- (cons "MT_TEST_RUN_DIR"
- (conc link-tree "/" target "/" runname "/" testname
- (if (and (string? itempath) (not (equal? itempath "")))
- (conc "/" itempath)
- "")))
- )
- '()))
-
- ,@(map
- (lambda (key)
- (cons (car key) (cadr key)))
- (keys:target->keyval (rmt:get-keys) target))
-
- ,@(map (lambda (var)
- (let ((val (configf:lookup *configdat* "env-override" var)))
- (cons var val)))
- (configf:section-vars *configdat* "env-override"))))
-
-;; set up needed environment variables given a run-id and optionally a target, itempath etc.
-;;
-(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
- ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
- (let* ((target (or intarget
- (common:args-get-target)
- (get-environment-variable "MT_TARGET")))
- (keys (if inkeys inkeys (rmt:get-keys)))
- (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
- (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
- (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
- (if testname (setenv "MT_TEST_NAME" testname))
- (if itempath (setenv "MT_ITEMPATH" itempath))
-
- ;; get the info from the db and put it in the cache
- (if link-tree
- (setenv "MT_LINKTREE" link-tree)
- (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
- (if (not vals)
- (let ((ht (make-hash-table)))
- (hash-table-set! *env-vars-by-run-id* run-id ht)
- (set! vals ht)
- (for-each
- (lambda (key)
- (hash-table-set! vals (car key) (cadr key)))
- keyvals)))
- ;; from the cached data set the vars
-
- (hash-table-for-each
- vals
- (lambda (key val)
- (debug:print 2 *default-log-port* "setenv " key " " val)
- (safe-setenv key val)))
- ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1")
- ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals))
-
- (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
- ;; we had a case where there was an exception generated by the hash-table-ref
- ;; due to *configdat* being #f Adding a handle and exit
- (let fatal-loop ((count 0))
- (handle-exceptions
- exn
- (let ((call-chain (get-call-chain))
- (msg ((condition-property-accessor 'exn 'message) exn)))
- (if (< count 5)
- (begin ;; this call is colliding, do some crude stuff to fix it.
- (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count
- ", exn=" exn)
- (launch:setup force-reread: #t)
- (fatal-loop (+ count 1)))
- (begin
- (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count
- " times. Message: " msg)
- (debug:print 0 *default-log-port* "Call chain:")
- (with-output-to-port *default-log-port*
-
- (lambda ()
- (print "*configdat* is >>"*configdat*"<<")
- (pp *configdat*)
- (pp call-chain)))
-
- (exit 1))))
- ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5")
- (when (or (not *configdat*) (not (hash-table? *configdat*)))
- (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.")
- ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.")
- (thread-sleep! 2) ;; assuming nfs lag.
- (launch:setup force-reread: #t))
- (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
- ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
- ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
- (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
- (if runname
- (setenv "MT_RUNNAME" runname)
- (debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- ;; if a testname and itempath are available set the remaining appropriate variables
- (if testname (setenv "MT_TEST_NAME" testname))
- (if itempath (setenv "MT_ITEMPATH" itempath))
- ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3")
- (if (and testname link-tree)
- (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
- (getenv "MT_TEST_NAME")
- (if (and itempath
- (not (equal? itempath "")))
- (conc "/" itempath)
- ""))))))
-
-(define (set-item-env-vars itemdat)
- (for-each (lambda (item)
- (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
- (setenv (car item) (cadr item)))
- itemdat))
-
;; Every time can-run-more-tests is called increment the delay
;;
;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine
;;
(define *last-num-running-tests* 0)
@@ -435,103 +315,10 @@
(debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf)
(system (conc run-pre-hook " >> " actual-logf " 2>&1"))
(debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))
(debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run.")))))
-
-
-(define (runs:run-post-hook run-id)
- (let* ((run-post-hook (configf:lookup *configdat* "runs" "post-hook"))
- (existing-tests (if run-post-hook
- (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
- #f #f ;; offset limit
- #f ;; not-in
- #f ;; sort-by
- #f ;; sort-order
- #f ;; get full data (not 'shortlist)
- 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
- 'dashboard)
- '()))
- (log-dir (conc *toppath* "/logs"))
- (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
- (full-log-fname (conc log-dir "/" log-file)))
- (if run-post-hook
- ;; (if (null? existing-tests)
- ;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
- (let* ((use-log-dir (if (not (directory-exists? log-dir))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn)
- #f)
- (create-directory log-dir #t)
- #t)
- #t))
- (start-time (current-seconds))
- (actual-logf (if use-log-dir full-log-fname log-file)))
- (handle-exceptions
- exn
- (begin
- (print-call-chain *default-log-port*)
- (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
- (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
- (system (conc run-post-hook " >> " actual-logf " 2>&1"))
- (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
-
-
-(define (runs:rerun-hook test-id new-test-path testdat rerunlst)
- (let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook"))
- (log-dir (conc *toppath* "/reruns/logs"))
- (target (getenv "MT_TARGET"))
- (runname (common:args-get-runname))
- (rundir (db:test-get-rundir testdat))
- (tarfiledir (conc *toppath* "/reruns"))
- (status (db:test-get-status testdat))
- (comment (conc "\"" (db:test-get-comment testdat) "\"" ))
- (testname (db:test-get-testname testdat))
- (itempath (db:test-get-item-path testdat))
- (file-body (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "")))
- (log-file (conc file-body ".log"))
- ;; (log-file (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".log"))
- (full-log-fname (conc log-dir "/" log-file))
- (tarfilename (conc file-body ".tar"))
- ;; (tarfilename (conc status "." (string-translate target "/" "-") "." runname "." testname (if (not (string=? itempath "")) (conc "." (string-translate itempath "/" "-")) "") ".tar"))
- )
- (if rerun-hook
- (let* ((use-log-dir (if (not (directory-exists? log-dir))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn)
- #f)
- (create-directory log-dir #t)
- #t)
- #t))
- (start-time (current-seconds))
- (actual-logf (if use-log-dir full-log-fname log-file))
- (sys-call-text (conc rerun-hook " " tarfilename " " rundir " " actual-logf " " runname " " tarfiledir " " status " " target " " comment " " testname " " itempath " >> " actual-logf " 2>&1"))
- )
- (debug:print 2 *default-log-port* "Found rerun-hook in config:" rerun-hook)
- (handle-exceptions
- exn
- (begin
- (print-call-chain *default-log-port*)
- (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (debug:print 0 *default-log-port* "ERROR: failed to run rerun-hook " rerun-hook ", check the log " log-file))
- (debug:print-info 0 *default-log-port* "running rerun-hook: \"" rerun-hook "\", log is " actual-logf)
- ;; call the hook
- (debug:print-info 0 *default-log-port* "Calling rerun-hook for " test-id new-test-path testdat rerunlst)
- (debug:print-info 0 *default-log-port* "rerun hook: " rerun-hook)
- (debug:print-info 0 *default-log-port* "tarfilename: " tarfilename)
- (debug:print-info 0 *default-log-port* "rundir: " rundir)
- (debug:print-info 0 *default-log-port* "actual-logf: " actual-logf)
- (debug:print-info 0 *default-log-port* "runname: " runname)
- (debug:print-info 0 *default-log-port* "sys-call-text: " sys-call-text)
- (system sys-call-text)
- (debug:print-info 0 *default-log-port* "rerun-hook \"" rerun-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
-
;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
@@ -2254,46 +2041,19 @@
(count (if (null? params) 1 (car params))))
(conc "/" (string-intersperse
(take dparts (- (length dparts) count))
"/"))))
-(define (runs:recursive-delete-with-error-msg real-dir)
- (if (> (system (conc "rm -rf " real-dir)) 0)
- (begin
- ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time
- (system (conc "chmod -R a+rwx " real-dir))
- (if (> (system (conc "rm -rf " real-dir)) 0)
- (debug:print-error 0 *default-log-port* "There was a problem removing " real-dir " with rm -f")))))
-
-(define (runs:safe-delete-test-dir real-dir)
- ;; first delete all sub-directories
- (directory-fold
- (lambda (f x)
- (let ((fullname (conc real-dir "/" f)))
- (if (directory? fullname)(runs:recursive-delete-with-error-msg fullname)))
- (+ 1 x))
- 0 real-dir)
- ;; then files other than *testdat.db*
- (directory-fold
- (lambda (f x)
- (let ((fullname (conc real-dir "/" f)))
- (if (not (string-search (regexp "testdat.db") f))
- (runs:recursive-delete-with-error-msg fullname)))
- (+ 1 x))
- 0 real-dir #t)
- ;; then the entire directory
- (runs:recursive-delete-with-error-msg real-dir))
-
;; cleanup often needs to remove all but the last N runs per target
;;
;; target-patts a1/b1/c1,a2/b2/c2 ...
;;
;; This will fail if called with empty target or a bad target (i.e. missing or extra fields)
;;
(define (runs:get-hash-by-target target-patts runpatt)
(let* ((targets (string-split target-patts ","))
- (keys (rmt:get-keys))
+ (keys (common:get-fields *configfdat*)) ;; (rmt:get-keys))
(res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
(for-each
(lambda (target-patt)
(let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f)))
(for-each
@@ -2365,16 +2125,15 @@
)
path-out
)
)
-
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '()))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
;; (tdbdat (tasks:open-db))
- (keys (rmt:get-keys))
+ (keys (common:get-fields *configdat*)) ;; (rmt:get-keys))
(rundat (mt:get-runs-by-patt keys runnamepatt target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
@@ -2745,75 +2504,10 @@
(print "db archived")))
)
#t
)
-(define (runs:remove-test-directory test mode) ;; remove-data-only)
- (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree
- (real-dir (if (common:file-exists? run-dir)
- ;; (resolve-pathname run-dir)
- (common:nice-path run-dir)
- #f))
- (clean-mode (or mode 'remove-all))
- (test-id (db:test-get-id test))
- ;; (lock-key (conc "test-" test-id))
- ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key))
- ;; (expire-time (+ (current-seconds) 30))) ;; give up on getting the lock and steal it after 15 seconds
- ;; (if (car lock)
- ;; #t
- ;; (if (> (current-seconds) expire-time)
- ;; (begin
- ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to clean test with id " test-id)
- ;; (rmt:no-sync-del! lock-key) ;; destroy the lock
- ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;;
- ;; (begin
- ;; (thread-sleep! 1)
- ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))))
- )
- (case clean-mode
- ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
- ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
- ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
- (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
- (if (and real-dir
- (> (string-length real-dir) 5)
- (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
- (let* ((realpath (realpath run-dir)))
- (debug:print-info 1 *default-log-port* "Recursively removing " realpath)
- (if (common:file-exists? realpath)
- (runs:safe-delete-test-dir realpath)
- (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
- (if real-dir
- (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
- (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
- (if (symbolic-link? run-dir)
- (begin
- (debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
- (handle-exceptions
- exn
- (debug:print-error 0 *default-log-port* " Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn)
- (delete-file run-dir)))
- (if (directory? run-dir)
- (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
- (debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty")
- (handle-exceptions
- exn
- (debug:print-error 0 *default-log-port* " Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue, exn=" exn)
- (delete-directory run-dir)))
- (if (and run-dir
- (not (member run-dir (list "n/a" "/tmp/badname"))))
- (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
- (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
- ))
- ;; Only delete the records *after* removing the directory. If things fail we have a record
- (case clean-mode
- ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f))
- ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
- (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))
- ;; (rmt:no-sync-del! lock-key)
- ))
-
;;======================================================================
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
@@ -2995,102 +2689,10 @@
"SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;")
(db:test-get-id testdat))))
))
prev-tests)))
-(define doc-template
- '(*TOP*
- (*PI* xml "version='1.0'")
- (testsuite)))
-
-(define (runs:update-junit-test-reporter-xml run-id)
- (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
- (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir"))
- (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
- (if junit-test-report-dir
- junit-test-report-dir
- (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
- #f))
- (xml-ts-name (if xml-dir
- (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
- #f))
- (keyname (if xml-ts-name (common:get-signature xml-ts-name) #f))
- (xml-path (if xml-dir
- (conc xml-dir "/" keyname ".xml")
- #f))
-
- (test-data (if xml-dir
- (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
- #f #f ;; offset limit
- #f ;; not-in
- #f ;; sort-by
- #f ;; sort-order
- #f ;; get full data (not 'shortlist)
- 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
- #f)
- '()))
- (tests-count (if xml-dir (length test-data) #f)))
- (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
- (begin
- ;((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count)))) doc)
-
- (let loop ((test (car test-data))
- (tail (cdr test-data))
- (doc doc-template)
- (fail-cnt 0)
- (error-cnt 0))
- (let* ((test-name (vector-ref test 2))
- (test-itempath (vector-ref test 11))
- (tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
- (test-state (vector-ref test 3))
- (comment (vector-ref test 14))
- (test-status (vector-ref test 4))
- (exc-msg (conc "No bucket for State " test-state " Status " test-status))
- (new-doc (cond
- ((member test-state (list "RUNNING" ))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
- ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
- ((member test-status (list "PASS" "WARN" "WAIVED"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
- ((member test-status (list "FAIL" "CHECK"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
- ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
- ((member test-status (list "SKIP"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
- (else
- (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
- (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
- (+ error-cnt 1)
- error-cnt))
- (new-fail-cnt (if (member test-status (list "FAIL" "CHECK"))
- (+ fail-cnt 1)
- fail-cnt)))
- (if (null? tail)
- (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
- (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
- (handle-exceptions
- exn
- (let* ((msg ((condition-property-accessor 'exn 'message) exn)))
- (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))
-
- (if (not (file-exists? xml-dir))
- (create-directory xml-dir #t))
- (if (not (rmt:no-sync-get/default keyname #f))
- (begin
- (rmt:no-sync-set keyname "on")
- (debug:print 0 *default-log-port* "creating xml at " xml-path)
- (with-output-to-file xml-path
- (lambda ()
- (print (sxml-serializer#serialize-sxml final-doc ns-prefixes: (list (cons 'gnm "http://foo"))))))
- (rmt:no-sync-del! keyname))
- (debug:print 0 *default-log-port* "Could not get the lock. Skip writing the xml file."))))
- (loop (car tail) (cdr tail) new-doc new-fail-cnt new-error-cnt))))))))
-
-
;; clean cache files
(define (runs:clean-cache target runname toppath)
(if target
(if runname
(let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree")))
@@ -3111,67 +2713,10 @@
(delete-file f)))
files))))
(debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
(debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))
-;; Spec for End of test
-;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup
-;; At transition to run COMPLETED/X do hooks
-;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND
-;; we can prove the process is not alive (ssh host pstree -A pid)
-;; if dead safe to mark the test as killed in the db
-;; State/status table
-;; new
-;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup
-;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na
-;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED
-;; 0 RUNNING ==> this is actually the first condition, should not get here
-
-(define (runs:end-of-run-check run-id )
- (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
- (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
- (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
- (current-state (rmt:get-run-state run-id))
- (current-status (rmt:get-run-status run-id)))
- ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing
- (debug:print 0 *default-log-port* "Running test cnt :" running-cnt)
- (rmt:set-state-status-and-roll-up-run run-id current-state current-status)
- (runs:update-junit-test-reporter-xml run-id)
- (cond
- ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
- (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
- (begin
- (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id)))
- (debug:print 0 *default-log-port* "End of Run Detected.")
- (rmt:set-var (conc "end-of-run-" run-id) "yes")
- ;(thread-sleep! 10)
- (runs:run-post-hook run-id)
- (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id)))
- (common:simple-unlock (conc "endOfRun" run-id)))
- (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id)))))
- ((> running-cnt 3)
- (debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
- ((> running-cnt 0)
- (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
- (let ((kill-cnt (launch:kill-tests-if-dead run-id)))
- (if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
- (runs:end-of-run-check run-id)))) ;;todo
- (else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt)
- (let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
- (if (> (length not-completed-tests) 0)
- (let loop ((running-test (car not-completed-tests))
- (tal (cdr not-completed-tests)))
- (let* ((test-name (vector-ref running-test 2))
- (item-path (vector-ref running-test 11)))
- (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
- (if (not (null? tal))
- (loop (car tal) (cdr tal)))))))))))
-
-(define (runs:find-and-mark-incomplete-and-check-end-of-run run-id ovr-deadtime)
- (rmt:find-and-mark-incomplete run-id ovr-deadtime)
- (runs:end-of-run-check run-id))
-
;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
;;
;; do a remote call to get the task queue info but do the killing as self here.
;;
(define (tasks:kill-runner target run-name testpatt)
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -102,27 +102,10 @@
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
(set! *my-client-signature* sig)
*my-client-signature*)))
-;; this one seems to be the general entry point
-;;
-(define (server:start-and-wait areapath #!key (timeout 60))
- (let ((give-up-time (+ (current-seconds) timeout)))
- (let loop ((server-info (server:check-if-running areapath))
- (try-num 0))
- (if (or server-info
- (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
- (server:record->url server-info)
- (let ((num-ok (length (server:get-best (server:get-list areapath)))))
- (if (and (> try-num 0) ;; first time through simply wait a little while then try again
- (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one
- (server:kind-run areapath))
- (thread-sleep! 5)
- (loop (server:check-if-running areapath)
- (+ try-num 1)))))))
-
(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
(define (server:kill servr)
(handle-exceptions
exn
Index: servermod.scm
==================================================================
--- servermod.scm
+++ servermod.scm
@@ -60,10 +60,15 @@
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
+(define (make-and-init-remote)
+ (make-remote hh-dat: (common:get-homehost)
+ server-info: (if *toppath* (server:check-if-running *toppath*) #f)
+ server-timeout: (server:expiration-timeout)))
+
;;======================================================================
;; 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)
;;
@@ -291,8 +296,25 @@
(debug:print-info 0 *default-log-port* "Gating server start, last start: "
fmodtime ", delta: " delta ", reftime: " reftime ", all-go=" all-go)
(thread-sleep! reftime)
(server:wait-for-server-start-last-flag areapath)))))))
+
+;; this one seems to be the general entry point
+;;
+(define (server:start-and-wait areapath #!key (timeout 60))
+ (let ((give-up-time (+ (current-seconds) timeout)))
+ (let loop ((server-info (server:check-if-running areapath))
+ (try-num 0))
+ (if (or server-info
+ (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
+ (server:record->url server-info)
+ (let ((num-ok (length (server:get-best (server:get-list areapath)))))
+ (if (and (> try-num 0) ;; first time through simply wait a little while then try again
+ (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one
+ (server:kind-run areapath))
+ (thread-sleep! 5)
+ (loop (server:check-if-running areapath)
+ (+ try-num 1)))))))
)
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -16,66 +16,10 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-;; summarize test in to a file test-summary.html in the test directory
-;;
-(define (tests:summarize-test run-id test-id)
- (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
- (out-dir (db:test-get-rundir test-dat))
- (out-file (conc out-dir "/test-summary.html")))
- ;; first verify we are able to write the output file
- (if (not (file-writable? out-dir))
- (debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir)
- (let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id))
- (test-name (db:test-get-testname test-dat))
- (item-path (db:test-get-item-path test-dat))
- (full-name (db:test-make-full-name test-name item-path))
- (oup (open-output-file out-file))
- (status (db:test-get-status test-dat))
- (color (common:get-color-from-status status))
- (logf (db:test-get-final_logf test-dat))
- (steps-dat (tests:get-compressed-steps run-id test-id)))
- ;; (dcommon:get-compressed-steps #f 1 30045)
- ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log"))
-
- (s:output-new
- oup
- (s:html
- (s:title "Summary for " full-name)
- (s:body
- (s:h2 "Summary for " full-name)
- (s:table 'cellspacing "0" 'border "1"
- (s:tr (s:td "run id") (s:td (db:test-get-run_id test-dat))
- (s:td "test id") (s:td (db:test-get-id test-dat)))
- (s:tr (s:td "testname") (s:td test-name)
- (s:td "itempath") (s:td item-path))
- (s:tr (s:td "state") (s:td (db:test-get-state test-dat))
- (s:td "status") (s:td (s:a 'href logf (s:font 'color color status))))
- (s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time
- (db:test-get-event_time test-dat)))
- (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat)))))
- (s:h3 "Log files")
- (s:table
- 'cellspacing "0" 'border "1"
- (s:tr (s:td "Final log")(s:td (s:a 'href logf logf))))
- (s:table
- 'cellspacing "0" 'border "1"
- (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File"))
- (map (lambda (step-dat)
- (s:tr (s:td (tdb:steps-table-get-stepname step-dat))
- (s:td (tdb:steps-table-get-start step-dat))
- (s:td (tdb:steps-table-get-end step-dat))
- (s:td (tdb:steps-table-get-status step-dat))
- (s:td (tdb:steps-table-get-runtime step-dat))
- (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat)))
- (s:a 'href step-log step-log)))))
- steps-dat))
- )))
- (close-output-port oup)))))
-
;; for each test:
;;
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
(let ((runnables '()))
Index: testsmod.scm
==================================================================
--- testsmod.scm
+++ testsmod.scm
@@ -20,12 +20,17 @@
(declare (unit testsmod))
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses itemsmod))
(declare (uses rmtmod))
+(declare (uses http-transportmod))
+(declare (uses stml2))
+(declare (uses dbmod))
+(declare (uses tasksmod))
(module testsmod
*
(import scheme
@@ -33,18 +38,22 @@
chicken.base
chicken.condition
chicken.file
chicken.io
chicken.pathname
+ chicken.file.posix
+ chicken.process-context.posix
+ chicken.format
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.sort
chicken.string
chicken.time
-
+ chicken.random
+
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
directory-utils
@@ -62,15 +71,20 @@
stack
typed-records
z3
debugprint
- mtargs
+ (prefix mtargs args:)
commonmod
pkts
itemsmod
rmtmod
+ http-transportmod
+ configfmod
+ stml2
+ dbmod
+ tasksmod
)
;;======================================================================
;; Tests
@@ -92,13 +106,13 @@
;; (import (prefix sqlite3 sqlite3:))
;; (require-library stml)
;;
;; (include "common_records.scm")
;; (include "key_records.scm")
-;; (include "db_records.scm")
+(include "db_records.scm")
(include "run_records.scm")
-;; (include "test_records.scm")
+(include "test_records.scm")
(include "js-path.scm")
(define (init-java-script-lib)
(set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
)
@@ -1402,9 +1416,68 @@
(define (test:archive db test-id)
#f)
(define (test:archive-tests db keynames target)
#f)
+
+
+;; summarize test in to a file test-summary.html in the test directory
+;;
+(define (tests:summarize-test run-id test-id)
+ (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
+ (out-dir (db:test-get-rundir test-dat))
+ (out-file (conc out-dir "/test-summary.html")))
+ ;; first verify we are able to write the output file
+ (if (not (file-writable? out-dir))
+ (debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir)
+ (let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id))
+ (test-name (db:test-get-testname test-dat))
+ (item-path (db:test-get-item-path test-dat))
+ (full-name (db:test-make-full-name test-name item-path))
+ (oup (open-output-file out-file))
+ (status (db:test-get-status test-dat))
+ (color (common:get-color-from-status status))
+ (logf (db:test-get-final_logf test-dat))
+ (steps-dat (tests:get-compressed-steps run-id test-id)))
+ ;; (dcommon:get-compressed-steps #f 1 30045)
+ ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log"))
+
+ (s:output-new
+ oup
+ (s:html
+ (s:title "Summary for " full-name)
+ (s:body
+ (s:h2 "Summary for " full-name)
+ (s:table 'cellspacing "0" 'border "1"
+ (s:tr (s:td "run id") (s:td (db:test-get-run_id test-dat))
+ (s:td "test id") (s:td (db:test-get-id test-dat)))
+ (s:tr (s:td "testname") (s:td test-name)
+ (s:td "itempath") (s:td item-path))
+ (s:tr (s:td "state") (s:td (db:test-get-state test-dat))
+ (s:td "status") (s:td (s:a 'href logf (s:font 'color color status))))
+ (s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time
+ (db:test-get-event_time test-dat)))
+ (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat)))))
+ (s:h3 "Log files")
+ (s:table
+ 'cellspacing "0" 'border "1"
+ (s:tr (s:td "Final log")(s:td (s:a 'href logf logf))))
+ (s:table
+ 'cellspacing "0" 'border "1"
+ (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File"))
+ (map (lambda (step-dat)
+ (s:tr (s:td (tdb:steps-table-get-stepname step-dat))
+ (s:td (tdb:steps-table-get-start step-dat))
+ (s:td (tdb:steps-table-get-end step-dat))
+ (s:td (tdb:steps-table-get-status step-dat))
+ (s:td (tdb:steps-table-get-runtime step-dat))
+ (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat)))
+ (s:a 'href step-log step-log)))))
+ steps-dat))
+ )))
+ (close-output-port oup)))))
+
+
)