;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit mtmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(module mtmod
*
(import scheme
chicken.base
chicken.condition
chicken.file
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.sort
chicken.string
chicken.time
debugprint
commonmod
configfmod
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
directory-utils
format
matchable
md5
message-digest
regex
regex-case
sparse-vectors
srfi-1
srfi-13
srfi-69
stack
typed-records
z3
)
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
(let loop ((testn (car tests))
(remt (cdr tests))
(res '()))
(let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
(waitons (vector-ref test-dat 2)))
;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
(if (null? remt)
(let ((new-res (reverse res)))
;; (print " new-res: " new-res)
new-res)
(loop (car remt)
(cdr remt)
(if (member failed-test waitons)
(begin
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================
;; (use format directory-utils)
;;
;; (declare (unit runconfig))
;; (declare (uses common))
;;
;; (include "common_records.scm")
;; 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
(string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/")
(or (common:args-get-target)
(get-environment-variable "MT_TARGET")
(begin
(debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg")
"nothing matches this I hope"))))
;; Why was system disallowed in the reading of the runconfigs file?
;; NOTE: Should be setting env vars based on (target|default)
(confdat (runconfig:read fname thekey environ-patt))
(whatfound (make-hash-table))
(finaldat (make-hash-table))
(sections (list "default" thekey)))
(if (not (bdat-target *bdat*))(bdat-target-set! *bdat* thekey)) ;; may save a db access or two but repeats db:get-target code
(debug:print 4 *default-log-port* "Using key=\"" thekey "\"")
(if change-env
(for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
(lambda (keyval)
(safe-setenv (car keyval)(cadr keyval)))
keyvals))
(for-each
(lambda (section)
(let ((section-dat (hash-table-ref/default confdat section #f)))
(if section-dat
(for-each
(lambda (envvar)
(let ((val (cadr (assoc envvar section-dat))))
(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
(if (and (string? envvar)
(string? val)
change-env)
(safe-setenv envvar val))
(hash-table-set! finaldat envvar val)))
(map car section-dat)))))
sections)
(if already-seen
(begin
(debug:print 2 *default-log-port* "Key settings found in runconfigs.config:")
(for-each (lambda (fullkey)
(debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
sections)
(debug:print 2 *default-log-port* "---")
(set! *already-seen-runconfig-info* #t)))
;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses
confdat
))
(define (set-run-config-vars run-id keyvals targ-from-db)
(push-directory *toppath*) ;; the push/pop doesn't appear to do anything ...
(let ((runconfigf (conc *toppath* "/runconfigs.config"))
(targ (or (common:args-get-target)
targ-from-db
(get-environment-variable "MT_TARGET"))))
(pop-directory)
(if (common:file-exists? runconfigf)
(setup-env-defaults runconfigf run-id #t keyvals
environ-patt: (conc "(default"
(if targ
(conc "|" targ ")")
")")))
(debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf))))
;; given (a (b c) d) return ((a b d)(a c d))
;; NOTE: this feels like it has been done before - perhaps with items handling?
;;
(define (runconfig:combinations inlst)
(let loop ((hed (car inlst))
(tal (cdr inlst))
(res '()))
;; (print "res: " res " hed: " hed)
(if (list? hed)
(let ((newres (if (null? res) ;; first time through convert incoming items to list of items
(map list hed)
(apply append
(map (lambda (r) ;; iterate over items in res
(map (lambda (h) ;; iterate over items in hed
(append r (list h)))
hed))
res)))))
;; (print "newres1: " newres)
(if (null? tal)
newres
(loop (car tal)(cdr tal) newres)))
(let ((newres (if (null? res)
(list (list hed))
(map (lambda (r)
(append r (list hed)))
res))))
;; (print "newres2: " newres)
(if (null? tal)
newres
(loop (car tal)(cdr tal) newres))))))
;; multi-part expand
;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f
;;
(define (runconfig:expand target)
(let* ((parts (map (lambda (x)
(string-split x ","))
(string-split target "/"))))
(map (lambda (x)
(string-intersperse x "/"))
(runconfig:combinations parts))))
;; multi-target expansion
;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y
;;
(define (runconfig:expand-target target-strs)
(delete-duplicates
(apply append (map runconfig:expand (string-split target-strs " ")))))
#|
(if (null? target-strs)
'()
(let loop ((hed (car target-strs))
(tal (cdr target-strs))
(res '()))
;; first break all parts into individual target patterns
(if (string-index hed " ") ;; this is a multi-target target
(let ((newres (append (string-split hed " ") res)))
(runconfig:expand-target newres))
(if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated
|#
)