;;======================================================================
;; Copyright 2006-2018, 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/>.
;;
;;======================================================================
;; NOTE: This is the configf module, long term it will replace configf.scm.
(module mtconfigf
(
set-debug-printers
lazy-convert
assoc-safe-add
section-var-set!
safe-file-exists?
read-link-f
nice-path
eval-string-in-environment
safe-setenv
with-env-vars
cmd-run->list
port->list
configf:system
process-line
shell
configf:read-line
cfgdat->env-alist
calc-allow-system
apply-wildcards
val->alist
section->val-alist
read-config
find-config
find-and-read-config
lookup
var-is?
lookup-number
section-vars
get-section
set-section-var
compress-multi-lines
expand-multi-lines
file->list
write-config
write-merge-config
read-refdb
map-all-hier-alist
config->alist
alist->config
read-alist
write-alist
config->ini
;;set-verbosity
add-eval-string
get-eval-string
squelch-debug-prints
;; misc
realpath
find-chicken-lib
)
(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18 pathname-expand posix-extras)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13 )
(use srfi-69)
(import posix)
;; stub debug printers overridden by set-debug-printers
(define (debug:print n e . args)
(apply print args))
(define (debug:print-info n e . args)
(apply print "INFO: " args))
(define (debug:print-error n e . args)
(apply print "ERROR: " args))
;;(import (prefix mtdebug debug:))
;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module
;; FROM common.scm
;;
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
(apply values
(map string->number
(take
(string-split (chicken-version) ".")
2)))))
(if (or (> chicken-release-number 4)
(and (eq? 4 chicken-release-number) (> chicken-major-version 9)))
(define ##sys#expand-home-path pathname-expand)))
;;(define (set-verbosity v)(debug:set-verbosity v))
(define *default-log-port* (current-error-port))
(define (debug:print-error n . args) ;;; n available to end-users but ignored for
;; default provided function
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: "args))))
(define (set-debug-printers normal-fn info-fn error-fn default-port)
(if error-fn (set! debug:print-error error-fn))
(if info-fn (set! debug:print-info info-fn))
(if normal-fn (set! debug:print normal-fn))
(if default-port (set! *default-log-port* default-port)))
(define (squelch-debug-prints)
(let ((noop (lambda x #f)))
(set! debug:print noop)
(set! debug:print-info noop)))
;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
(let* ((as-num (if (string? inval)(string->number inval) #f)))
(or as-num inval)))
(define *eval-string* "")
(define (add-eval-string str)
(if (not (string-contains *eval-string* str))
(set! *eval-string* (conc *eval-string* " " str))))
(define (get-eval-string) *eval-string*)
;; Moved to common
;;
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
(if toppath
(let ((cfname (conc toppath "/" configname)))
(if (safe-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 (safe-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 (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 (section-var-set! cfgdat section-name var value #!key (metadata #f))
(hash-table-set! cfgdat section-name
(assoc-safe-add
(hash-table-ref/default cfgdat section-name '())
var value metadata: metadata)))
;;======================================================================
;; Environment handling stuff
;;======================================================================
(define (safe-file-exists? path)
(handle-exceptions exn #f (file-exists? path)))
(define (read-link-f path)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.")
path) ;; just give up
(with-input-from-pipe
(conc "/bin/readlink -f " path)
(lambda ()
(read-line)))))
;; return a nice clean pathname made absolute
(define (nice-path dir)
(let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
(if match ;; using ~ for home?
(nice-path (conc #;(read-link-f (cadr match))
(realpath (cadr match))
"/" (caddr match)))
(normalize-pathname (if (absolute-pathname? dir)
dir
(conc (current-directory) "/" dir))))))
(define (eval-string-in-environment str)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment")
#f)
(let ((cmdres (cmd-run->list (conc "echo " str))))
(if (null? cmdres) ""
(caar cmdres)))))
(define (safe-setenv key val)
(if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"")
(if (and (string? val)
(string? key))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
(setenv key val))
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
;; execute thunk in context of environment modified as per this list
;; restore env to prior state then return value of eval'd thunk.
;; ** this is not thread safe **
(define (with-env-vars delta-env-alist-or-hash-table thunk)
(let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
(hash-table->alist delta-env-alist-or-hash-table)
delta-env-alist-or-hash-table))
(restore-thunks
(filter
identity
(map (lambda (env-pair)
(let* ((env-var (car env-pair))
(new-val (let ((tmp (cdr env-pair)))
(if (list? tmp) (car tmp) tmp)))
(current-val (get-environment-variable env-var))
(restore-thunk
(cond
((not current-val) (lambda () (unsetenv env-var)))
((not (string? new-val)) #f)
((eq? current-val new-val) #f)
(else
(lambda () (setenv env-var current-val))))))
;;(when (not (string? new-val))
;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
;; (pp delta-env-alist)
;; (exit 1))
(cond
((not new-val) ;; modify env here
(unsetenv env-var))
((string? new-val)
(setenv env-var new-val)))
restore-thunk))
delta-env-alist))))
(let ((rv (thunk)))
(for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
rv)))
(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
(with-env-vars
delta-env-alist-or-hash-table
(lambda ()
(let* ((fh (open-input-pipe cmd))
(res (port->list fh))
(status (close-input-pipe fh)))
(list res status)))))
(define (port->list fh)
(if (eof-object? fh) #f
(let loop ((curr (read-line fh))
(result '()))
(if (not (eof-object? curr))
(loop (read-line fh)
(append result (list curr)))
result))))
;;======================================================================
;; 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*$"))
(define configf:initstr-rx (regexp "^\\[configf:initstr\\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)
)
;; Lookup a value in runconfigs based on -reqtarg or -target
;;
(define (runconfigs-get config var) ;; .dvars is a special bin for storing metadata such as target
(let ((targ (lookup config ".dvars" "target"))) ;; (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(if targ
(or (lookup config targ var)
(lookup config "default" var))
(lookup config "default" var))))
(define (realpath x)
(let ((currdir (current-directory)))
(handle-exceptions
exn
(begin
(change-directory currdir)
x) ;; anything goes wrong - return given path
(change-directory x)
(let ((result (current-directory)))
(change-directory currdir)
result))))
;; (resolve-pathname (pathname-expand (or x "/dev/null")) ))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
(let* ((this-script
(cond
((and (> (length argv) 2)
(string-match "^(.*/csi|csi)$" (car argv))
(string-match "^-(s|ss|sx|script)$" (cadr argv)))
(caddr argv))
(else (car argv))))
(fullpath (realpath this-script)))
fullpath))
;; (use trace)
;; (trace-call-sites #t)
;; (trace realpath common:get-this-exe-fullpath)
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
(define (find-chicken-lib)
(let* ((ckhome (chicken-home))
(libpath-number (car (reverse (string-split (repository-path) "/"))))
(libpath (conc *common:this-exe-dir* "/../../eggs/lib/chicken/" libpath-number)))
(if (and (not (get-environment-variable "CHICKEN_REPOSITORY"))
(directory-exists? libpath))
(conc "(repository-path \""libpath"\") ")
"")))
(define (process-line l ht allow-system #!key (linenum #f)(extend-eval ""))
(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-milliseconds))
(cmdsym (string->symbol cmdtype))
(presnip (conc "(import posix)(import directory-utils)"
"(set! getenv get-environment-variable)"
))
(allsnip (conc "(import posix)(import directory-utils)"
"(set! getenv get-environment-variable)"
(find-chicken-lib)
"(import (prefix mtconfigf configf:))"
"(import mtconfigf)"
*eval-string*))
(fullcmd (case cmdsym
((scheme scm) (conc "(lambda (ht)" allsnip "" cmd "))"))
((system) (conc "(lambda (ht)" allsnip "(configf:system ht \"" cmd "\"))"))
((shell sh) (conc "(lambda (ht)" allsnip "(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
((realpath rp)(conc "(lambda (ht)" allsnip "(configf:nice-path \"" cmd "\"))"))
((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
((mtrah) (conc "(lambda (ht)"
allsnip
" (let ((extra \"" cmd "\"))"
" (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
" (if (string-null? extra) \"\" \"/\")"
" extra)))"))
((get g)
(let* ((parts (string-split cmd))
(sect (car parts))
(var (cadr parts)))
(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")))
;;((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(configf:runconfigs-get ht \"" cmd "\"))"))
((runconfigs-get rget)
(runconfigs-get ht cmd))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
(handle-exceptions
exn
(let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
(message ((condition-property-accessor 'exn 'message) exn))
(allstr (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
(debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
(debug:print 0 *default-log-port* " message: " message
(if arguments
(conc "; " (string-intersperse (map conc arguments) ", "))
""))
(debug:print 0 *default-log-port* "INFO: allstr is\n" allstr)
;; (debug:print 0 *default-log-port* "exn=" (condition->list exn))
(set! result allstr))
(if (or allow-system
(not (member cmdtype '("system" "shell" "sh"))))
(if (member cmdsym '(runconfigs-get rget))
(begin
(set! result fullcmd)
fullcmd)
(with-input-from-string fullcmd
(lambda ()
(set! result ((eval (read)
;;(module-environment 'mtconfigf)
) ht)))))
(set! result (conc "#{(" cmdtype ") " cmd "}"))))
(case cmdsym
((system shell scheme scm sh)
(let ((delta (- (current-milliseconds) start-time)))
(if (> delta 2000)
(debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " (/ delta 1000) " seconds to run with output:\n " result)
(debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " (/ delta 1000) " 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 (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 #!key ....)
(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)
(process-line inl ht allow-processing))
((return-string)
inl)
(else
(process-line inl ht allow-processing)))))
(if (string? res)
(let* ((r1 (if (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))
(string-substitute "\\s+$" "" res)
res))
(r2 (if (not (equal? (hash-table-ref/default settings "line-end-comments" "no") "no"))
(string-substitute "\\s*#+[^\\{]*.*$" "" r1)
r1)))
r2)
res))))))
(define (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 (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 (assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
vars)))))
(hash-table-keys ht))))
ht)
;;======================================================================
;; Extended config lines, allows storing more hierarchial data in the config lines
;; ABC a=1; b=hello world; c=a
;;
;; NOTE: implementation is quite limited. You currently cannot have
;; semicolons in your string values.
;;======================================================================
;; convert string a=1; b=2; c=a silly thing; d=
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (val->alist val #!key (convert #f))
(let ((val-list (string-split-fields ";\\s*" val #:infix)))
(if val-list
(map (lambda (x)
(let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
(case (length f)
((0) `(,#f)) ;; null string case
((1) `(,(string->symbol (car f))))
((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
(if convert (lazy-convert inval) inval))))
(else f))))
val-list)
'())))
;; I don't want configf to turn into a weak yaml format but this extention is really useful
;;
(define (section->val-alist cfgdat section-name #!key (convert #f))
(let ((section (get-section cfgdat section-name)))
(map (lambda (item)
(let ((key (car item))
(val (cadr item))) ;; BUG IN WAIT. sections are not returned as proper alists, should fix this.
(cons key (val->alist val convert: convert))))
section)))
;; 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
;;
;; NOTE: apply-wild variable is intentional (but a better name would be good)
;;
(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-wild #t) )
(debug:print 9 *default-log-port* "BB> read-config > keep-filenames: " keep-filenames)
(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 (safe-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* ((have-file (string? path))
(inp (if have-file
(open-input-file path)
path)) ;; we can be handed a port
(res (if (not ht)(make-hash-table) ht))
(metapath (if keep-filenames
path #f))
(process-wildcards (lambda (res curr-section-name)
(if (and apply-wild
(or (string-contains curr-section-name "%") ;; wildcard
(string-match "/.*/" curr-section-name))) ;; regex
(begin
(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 have-file ;; 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:initstr-rx ( x initstr )
(begin
(add-eval-string initstr)
(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
(nice-path
(conc (if curr-conf-dir
curr-conf-dir
".")
"/" include-file))))
(all-matches (sort (handle-exceptions 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 (safe-file-exists? include-script)(file-execute-access? include-script))
(let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
(env-delta (cfgdat->env-alist curr-section-name res local-allow-system))
(new-inp-port
(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 (cfgdat->env-alist curr-section-name res local-allow-system))
(cmdres (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
(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
(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)
(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
(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
(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
(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
(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
)))
;; look at common:set-fields for an example of how to use the set-fields proc
;; 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)(set-fields #f)(keep-filenames #f))
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
(toppath (car configinfo))
(configfile (cadr configinfo)))
(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: (if set-fields (list (cons "^fields$" set-fields) ) '())
#f
keep-filenames: keep-filenames))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
(define (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
;;
;; (var-is? cfgdat "foo" "var" "yes") => #t
;;
(define (var-is? cfgdat section var expected-val)
(equal? (lookup cfgdat section var) expected-val))
;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (lookup-number cfgdat section varname #!key (default #f))
(let* ((val (lookup cfgdat 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 (section-vars cfgdat section)
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
'()
(map car sectdat))))
(define (get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
(define (set-section-var cfgdat section var val)
(let ((sectdat (get-section cfgdat section)))
(hash-table-set! cfgdat section
(assoc-safe-add sectdat var val))))
;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
;; (list var val))))
;; moved to common
;; (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 (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 (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 (file->list fname)
(if (safe-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)))))
'()))
;; raw basic write config in ini format
;;
(define (write-config cfgdat fname)
(with-output-to-file fname
(lambda ()
(config->ini cfgdat))))
;; (for-each
;; (lambda (section)
;; (let ((sec-dat (hash-table-ref cfgdat section)))
;; (for-each (lambda (entry)(print (car entry) " " (cadr entry))) sec-dat)))
;; (sort (hash-table-keys cfgdat) (lambda (a b)(string<= a b)))))))
;;======================================================================
;; 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 (write-merge-config indat fname #!key (required-sections '()))
(let* (;; step 1: Open the output file and read it into a list
(fdat (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 (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)
(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 (lookup indat secname key))) ;; secname was sec. I think that was a bug
;; 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 (section-vars indat section)))
(for-each
(lambda (var)
(let ((val (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))
(expand-multi-lines fdat))))))
;;======================================================================
;; refdb
;;======================================================================
;; reads a refdb into an assoc array of assoc arrays
;; returns (list dat msg)
(define (read-refdb refdb-path)
(let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
(if (not (safe-file-exists? sheets-file))
(list #f (conc "ERROR: no refdb found at " refdb-path))
(if (not (file-read-access? 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 (read-config 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 (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 (config->alist cfgdat)
(hash-table->alist cfgdat))
(define (alist->config adat)
(let ((ht (make-hash-table)))
(for-each
(lambda (section)
(hash-table-set! ht (car section)(cdr section)))
adat)
ht))
;; if
(define (read-alist fname)
(handle-exceptions
exn
#f
(alist->config
(with-input-from-file fname read))))
(define (write-alist cdat fname #!key (locker #f)(unlocker #f))
(if (and locker (not (locker fname)))
(debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
(let* ((dat (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 (read-alist fname)
#t ;; data is good.
(begin
(handle-exceptions
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))))
(if unlocker (unlocker fname))
res))
;; convert config hash-table/list data to ini format
;;
(define (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)))
;(use trace)
;(trace-call-sites #t)
;(trace read-config)
)