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

	 configf:set-section-var
	 configf:var-is?
	 configf:write-alist
	 configf:write-config
	 find-config
	 getenv
	 mytarget
	 my-with-lock
	 nice-path
	 process:cmd-run->list
	 runconfig:read
	 runconfigs-get
	 safe-setenv
	 setenv
	 configf:eval-string-in-environment

	(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

;;======================================================================
;; parameters
;;======================================================================

;; while targets are Megatest specific they are a useful concept
(define mytarget (make-parameter #f))

;; fake locker
(define (fake-locker fname proc)(proc))

;; locking is optional, many environments don't care (e.g. running on one machine)
;; NOTE: the locker must follow the same syntax as with-dot-lock*
;;       with-dot-lock* has problems if /tmp and the file being
;;       locked are not on the same filesystem
;;
(define my-with-lock (make-parameter with-dot-lock*))
(define my-with-lock (make-parameter fake-locker)) ;; with-dot-lock*))

;;======================================================================
;; move debug stuff to separate module then put these back where they belong
;;======================================================================
;;======================================================================
;; lookup routines - replicated from configf
;;======================================================================

	    (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 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)
	 (if (or allow-system
		 (not (member cmdtype '("system" "shell" "sh"))))
	     (begin
	       (debug:print 0 *default-log-port* "eval: "newres)
	       (with-input-from-string newres
		 (lambda ()
		   (set! result
      (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))
			 (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: " fullcmd)))
	       		    (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 "}")))))
			  (if env-to-use
			      ((eval (read) env-to-use) ht)
			      ((eval (read)) ht)
			      ))))))
	     (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)"

    (configf:alist->config
     (with-input-from-file fname read))))

;;======================================================================
;; DO THE LOCKING AROUND THE CALL
;;======================================================================
;;
(define (configf:write-alist cdat fname)
(define (configf:write-alist cdat fname #!optional (check-written #f))
  ;; (if (not (common:faux-lock fname))
  ;; (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname)
  ((my-with-lock)
   fname
   (lambda ()
     (let* ((dat  (configf:config->alist cdat))
            (res
             (begin
               (with-output-to-file fname ;; first write out the file
		 (lambda ()
                   (pp dat)))
               ;; I don't like this. It makes write-alist opaque and complicated. -mrw-
               (if (file-exists? fname)   ;; now verify it is readable
                   (if (configf:read-alist fname)
                       #t ;; data is good.
               ;; I don't like this. It makes write-alist complicated
	       ;; move to something like write-and-verify-alist. -mrw-
               (if check-written
		   (if (file-exists? fname)   ;; now verify it is readable
		       (if (configf:read-alist fname)
			   'data-good ;; data is good.
                       (begin
			 (handle-exceptions
			  exn
			  (begin
			    (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
			   (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))
				 'data-bad)
			     (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
			     (delete-file fname)))
			 #f))
                   #f))))
		       'data-not-there)
		   'data-not-checked))))
       res))))
  
(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

)