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 fake-locker)) ;; with-dot-lock*))

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

      (let (;; (env-to-use (if env-to-use env-to-use (module-environment 'configfmod)))
	    (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" "toppath"))
			        (configf:set-section-var ht-in "toppath" "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
                                               (string-match "/.*/" curr-section-name))) ;; regex
                                      (begin
                                        (configf: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 env-to-use)) ;; (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))

	  (if (eof-object? inl) 
	      (begin
                ;; process last section for wildcards
                (process-wildcards res curr-section-name)
		(if (string? path) ;; 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 env-to-use)
                                                            curr-section-name #f #f))

		      (print var " " val)))
		  section-dat))))) ;;       (print "section-dat: " section-dat))
   (hash-table->alist data)))

(define (runconfig:read fname target environ-patt)
  (let ((ht (make-hash-table)))
    (if target (hash-table-set! ht target '()))
    (configf:set-section-var ht "toppath" "toppath" (getenv "PWD"))
    (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "toppath" "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: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" "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" "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 "\"))"))
		((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht cmd))) ;; (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 "\", eval-needed, newres="newres", exn="(condition->list exn))
	       		    (debug:print 0 *default-log-port* " message1: " ((condition-property-accessor 'exn 'message) exn))

	       		    (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " newres)))




			  (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))
  (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

			     ;;"(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)"

			       ;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
			       (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
		   (debug:print 0 *default-log-port* " message2: " ((condition-property-accessor 'exn 'message) exn))
		   ;; (print "exn=" (condition->list exn))
		   (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
		 (if (or allow-system
			 (not (member cmdtype '("system" "shell" "sh"))))
		     (with-input-from-string fullcmd
		       (lambda ()
			 (set! result (if env-to-use

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

;;======================================================================
;; DO THE LOCKING AROUND THE CALL
;;======================================================================
;;
(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 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.

			   (handle-exceptions
			       exn
			       (begin
				 (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)

				 'data-bad)
			     (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
			     (delete-file fname)))

		       'data-not-there)
		   'data-not-checked))))
       res))))
  
(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

)