Megatest

;;     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 configfmod))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses rmtmod))
(declare (uses debugprint))
(declare (uses keysmod))

(module configfmod
	(
	 common:get-fields
	 common:nice-path

	(prefix dbi dbi:)
	(prefix sqlite3 sqlite3:)
	(srfi 18)
	directory-utils
	dot-locking
	format
	matchable
	mtargs
	md5
	message-digest
	regex
	regex-case
	sparse-vectors
	srfi-1
	srfi-13

	    (inp        (if (string? path)
			    (open-input-file path)
			      path)) ;; we can be handed a port
	    (res        (let ((ht-in (if (not ht)
					 (make-hash-table)
					 ht)))
			  (if (not (configf:lookup ht-in "" "toppath"))
			      (configf:set-section-var ht-in "" "toppath" path))
			      (configf:set-section-var ht-in "" "toppath" (pathname-directory path)))
			  ht-in))
	    (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

    (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))

;;======================================================================
;; Config file handling
;;======================================================================

;; convert to param?
(define configf:std-imports "(import scheme big-chicken system-information simple-exceptions big-chicken configfmod commonmod rmtmod chicken.process-context.posix)(import (prefix mtargs args:))(define getenv get-environment-variable)")
(define configf:std-imports "(import simple-exceptions big-chicken configfmod commonmod rmtmod (prefix mtargs args:))")

(define (configf:process-one matchdat l ht allow-system env-to-use linenum)
  (let* ((prestr  (list-ref matchdat 1))
	 (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
	 (cmd     (list-ref matchdat 3))
	 (quotedcmd (conc "\""cmd"\""))
	 (poststr (list-ref matchdat 4))
	 (result  #f)
	 (start-time (current-seconds))
	 (cmdsym  (string->symbol cmdtype))
	 (fullcmd
	  (if (member cmdsym '(scheme scm))
	      `(eval-needed
		,(conc  "(lambda (ht)"
			configf:std-imports
			"(set! *toppath* \""(configf:lookup ht "" "toppath")"\")"
			cmd ")"))
	      (case cmdsym
		((system)     `(noeval-needed  ,(conc (configf:system ht cmd))))
		;; ((shell sh)   `(noeval-needed  ,(conc (string-translate (shell quotedcmd) "\n" " "))))
		((shell sh)   `(noeval-needed  ,(conc (string-translate (shell cmd) "\n" " "))))
		((realpath rp)`(noeval-needed  ,(conc (common:nice-path quotedcmd))))
		((getenv gv)  `(noeval-needed  ,(conc (get-environment-variable cmd))))
		((mtrah)      `(noeval-needed  ,(configf:lookup ht "" "toppath")))
		((get g)   
		 (match
		  (string-split cmd)
		  ((sect var) `(noeval-needed ,(configf:lookup ht sect var)))
		  (else
		   (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
		   '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
		((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
		(else `(#f ,(conc "cmd: " cmd " not recognised")))))))
    (match
     fullcmd
     (('eval-needed newres)
      (handle-exceptions
	 exn
	 (begin
	   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", fullcmd="fullcmd", 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)))
;;(handle-exceptions
;;	 exn
;;	 (begin
;;	   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", eval-needed, newres="newres", exn="(condition->list 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: " newres)))
	 (if (or allow-system
		 (not (member cmdtype '("system" "shell" "sh"))))
	     (with-input-from-string newres
	       (lambda ()
		 (set! result (if env-to-use
				  ((eval (read) env-to-use) ht)
				  ((eval (read)) ht)
				  ))))
	     (set! result (conc "#{(" cmdtype ") "  cmd "}")))))
	     (set! result (conc "#{(" cmdtype ") "  cmd "}")))); )
     (('noeval-needed newres)(set! result newres))
     (else ;; (#f errres)
      (debug:print 0 *default-log-port* "WARNING: failed to process config input \""l"\", fullcmd="fullcmd".")))
    ;; we process as a result
    (let ((delta (- (current-seconds) start-time)))
      (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result))
    (conc prestr result poststr)))
	      
(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum)))
		(loop result))
	      res))
	  res)))

(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f))
#;(define (configf:process-line-old l ht allow-system env-to-use #!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
		      (conc  configf:std-imports
			     "(import chicken.process-context.posix)"
			     "(define setenv set-environment-variable)"
			     ;;"(define setenv set-environment-variable)"
			     (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)"