@@ -31,92 +31,67 @@ (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses common)) (declare (uses commonmod)) (declare (uses commonmod.import)) +(declare (uses configfmod)) +(declare (uses configfmod.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) (declare (uses dbmod.import)) (import commonmod + configfmod (prefix mtargs args:) debugprint) (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)))))) - -;; this is used in megatestqa/ext.scm. -;; remove it from here and there by 12/31/21 -;; (define config:assoc-safe-add configf:assoc-safe-add) - -(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:imports "(import commonmod (prefix mtargs args:))") +(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)) + +;; 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: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))) @@ -170,27 +145,10 @@ (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 ;; why is this printing to error-port and not using debug:print? -mrw- - (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) @@ -214,62 +172,10 @@ (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: @@ -505,232 +411,17 @@ (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 cfgdat section varname #!key (default #f)) - (let* ((val (configf: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 (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 @@ -760,95 +451,10 @@ ;; (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))) + + +;; redefines +(define config-lookup configf:lookup) +(define configf:read-file read-config)