@@ -17,59 +17,439 @@
 ;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;======================================================================
 
 (declare (unit configfmod))
-;; (declare (uses mtargs))
-;; (declare (uses debugprint))
-;; (declare (uses keysmod))
+(declare (uses debugprint))
+(declare (uses commonmod))
+(declare (uses processmod))
+
+(use regex regex-case)
 
 (module configfmod
 *	
 
-(import srfi-1
-  
-;;        scheme
-;;
-;;	big-chicken        ;; more of a reminder than anything ...
-;;	chicken.base
-;;	chicken.condition
-;;	chicken.file
-;;	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.eval
-;;	
-;;	debugprint
-;;	(prefix mtargs args:)
-;;	pkts
-;;	keysmod
-;;
-;;	(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
-	
-	)
+(import scheme
+        chicken
+	extras
+	files
+	matchable
+	ports
+	srfi-1
+	srfi-13
+	srfi-69
+	
+	posix
+	data-structures
+
+	regex
+	regex-case
+	
+	)
+
+(import debugprint
+	commonmod
+	processmod)
+
+;; 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)))
+	  ""))))
+
+;; 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: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)
+
+(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))
+
+;; 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))))
+
+;;======================================================================
+;; 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))))))
+
+;; 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))))
+
+  
+;; 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)))
+
+
 )