(module scfg mzscheme
	(provide scfg-new 
		 scfg-map 
		 scfg-save
		 scfg-get
		 scfg-set!
		 scfg-cond-set!-get
		 scfg-filename
		 scfg-rm!
		 scfg-multi-get
		 scfg-multi-set!)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;#+pod
;
;=pod
;
;=syn scm,8
;
;=wikiwikiwiki
;
;=SCFG - Simple configuration files
;
;A module that can be used for reading and writing simple configuration files.
;The file format is encapsulated. It is however currently scheme write/read format.
;Later, maybe it will use XML.
;
;Currently this module doesn't work multi-user, i.e. concurrent use of configuration
;files will most likely result in problems. If you're going to use #scfg# configuration
;files concurrently, you'll have to provide your own locking.
;
;=Synopsis
;
; >(require (planet "scfg.scm" ("oesterholt" "ho-utils.plt" 1 0)))
; >(define cfg (sfg-new "config.scfg"))
; >(scfg-set! a '(a configuration parameter) "a-value")
; >(scfg-set! a '(another config par) (list 'a 'list 'of 'values))
; >(scfg-set! a 'par1 12)
; >(define I 1)
; >(scfg-set! a (list 'par 'value I) (* I (post++ I)))
; >(scfg-set! a (list 'par 'value I) (* I (post++ I)))
; >(scfg-set! a (list 'par 'value I) (* I (post++ I)))
;
; >(scfg-get a (list 'par 'value 2))
; 4
;
; >(scfg-get a (list 'par 'value 8))
; undef
;
; >(scfg-get a (list 'par 'value 8) "HI!")
; "HI!"
;
;
; > (scfg-map (lambda (key val) (display (format "~a=~a~%" key val)) val) a)
;
; (par value 3)=9
; (par value 2)=4
; (par value 1)=1
; (par1)=12
; (another config par)=(a list of values)
; (a configuration parameter)=a-value
; (%scfg version)=$Id: scfg.scm,v 1.2 2006/05/27 17:38:02 hoesterholt Exp $
; (%scfg filename)=config.scfg
;
; ("config.scfg" "$Id: scfg.scm,v 1.2 2006/05/27 17:38:02 hoesterholt Exp $" "a-value" (a list of values) 12 1 4 9)
;
; > (scfg-rm! a (list 'par 'value 2))
; #<procedure:proc>
; > (scfg-get a (list 'par 'value 2))
; undef
; > (scfg-rm! a (list 'par 'value 8))
; #<procedure:proc>
;
; > (scfg-save a)
; #<procedure:proc>
; > (scfg-filename a)
; "config.scfg"
; > (scfg-save a "new.scfg")
; #<procedure:proc>
; > (scfg-filename a)
; "new.scfg"
; > (scfg-save a "d:/")
; open-output-file: "d:/" exists as a directory
; > (scfg-filename a)
; "new.scfg"
;
;=API
;
;==Standard use
;
;===#(scfg-new . <file>) : scfg-handle#
;
;Creates or reads #file# into memory for use as scfg structure.
;/Returns/ an scfg handle. If no #file# is provided, only
;a new scfg-handle is created, but no contents are read from
;file.
;
;===#(scfg-save <scfg-handle> . <file>) : <scfg-handle>#
;
;Writes the current contents of #scfg handle# to the #filename# given with
;the #scfg-new# function or the given #file# parameter. /Returns/ the
;given #scfg-handle#.
;
;===#(scfg-set! <scfg-handle> <key> <value>) : <scfg-handle>#
;
;Sets #key# to #value#. #key# can be  a symbol or number or a list of symbols and
;numbers.
;
;===#(scfg-get <scfg-handle> <key> . <default-value>) : <value>#
;
;Returns the value associated with #key#, or, if #key# doesn't exist
;withing #scfg-handle#, the #default-value#, if given, or #'undef#, if
;no default value has been given.
;
;===#(scfg-rm! <scfg-handle> <key>): <scfg-handle>#
;
;Removes #key# from the #scfg-handle#. If #key# doesn't exist, it
;doesn't complain. /Returns/ the given #scfg-handle#.
;
;===#(scfg-filename <scfg-handle>) : string#
;
;/Returns/ the current associated filename with the #scfg-handle#. The current
;associated filename is the last one saved or the one provided with #scfg-new#.
;
;===#(scfg-cond-set!-get <scfg-handle> <key> <default> . <value>) : <value>#
;
;Sets #key# in #scfg-handle#, if #value# has been given. /Returns/ the current
;#value# associated with #key#, or #default#, if #key# does not exist within
;#scfg-handle#.
;
;==Concurrent use
;
;===#(scfg-multi-get <scfg-handle> <key> . <default>) : <value>###
;
;Should provide concurrent access to the scfg configuration file. Is
;currently a call to #scfg-get#.
;
;===#(scfg-multi-set! <scfg-handle> <key> <value>) : <scfg-handle>###
;
;Should provide concurrent access to the scfg configuration file. Is
;currently a call to #scfg-set!# followed by a call to #scfg-save#.
;
;
;=Info
;
;(c) 2005 Hans !Oesterholt-Dijkema. Distributed undef LGPL.
;Contact: send email to hans in domain elemental-programming.org.
;Homepage: [http://www.elemental-programming.org].
;
;=wikiwikiwiki
;
;=cut
;=verbatim
;
;##

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define-syntax debug
  (syntax-rules ()
    ((_ a1 ...)
     #t)))

;;;;;;;;;;;; scfg-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (internal-scfg-map function cfg)
  (let ((L (list)))

    (define (walk key cfg)
      (debug key  " - " cfg)
      (if (null? cfg)
	  #t
	  (for-each (lambda (key-part)
					; expected: ('key (list of indepths) (list [value]))
		      (debug key-part)
		      (let ((local-key   (car key-part))
			    (next-levels (cadr key-part))
			    (value       (caddr key-part)))
			(let ((full-key (append key (list local-key))))
			  (if (not (null? value))
			      (set! L (cons (function full-key (car value)) L)))
			  (walk full-key (cadr key-part)))))
		    cfg)))
    
    (walk (list) cfg)
    L))

(define (%scfg-map proc function cfg)
  (internal-scfg-map function (car cfg)))

(define (scfg-map function cfg)
  (cfg '%scfg-map function))

;;;;;;;;;;;; scfg-set ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (internal-scfg-set cfg key value)

  (define (search-key-part part cfg)
    (if (null? cfg)
	#f
	(if (equal? (caar cfg) part)
	    (car cfg)
	    (search-key-part part (cdr cfg)))))

  (define (create-new-tree key)
    (if (null? (cdr key))
	(list (car key) (list) (list value))
	(list (car key) (list (create-new-tree (cdr key))) (list))))

  (define (walk key cfg)
    (debug key  " - " cfg)
    (if (null? key)
	(error "unexpected")
	(let ((entry (search-key-part (car key) cfg)))
	  (debug "entry:" entry)
	  (if (eq? entry #f)
	      (let ((nt (create-new-tree key)))
		(debug "cfg:" cfg " nt:" nt)
		(cons nt cfg))
	      (if (null? (cdr key))
		  (begin
		    (set-car! (cddr entry) (list value))
		    cfg)
		  (begin
		    (set-car! (cdr entry) (walk (cdr key) (cadr entry)))
		    (debug "entry>>:" entry)
		    cfg))))))

  (walk key cfg))

(define (%scfg-set! proc cfg key value)
  (set-car! cfg (internal-scfg-set 
		 (car cfg) 
		 (if (symbol? key) 
		     (list key)
		     key) 
		 value))
  proc)


(define (scfg-set! proc key value)
  (proc key value))

(define (scfg-cond-set!-get cfg key default . value)
  (if (not (null? value))
      (scfg-set! cfg key (car value)))
  (scfg-get cfg key default))

;;;;;;;;;;;; scfg-get  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (internal-scfg-get cfg key)

  (define (search-key-part part cfg)
    (if (null? cfg)
	#f
	(if (equal? (caar cfg) part)
	    (car cfg)
	    (search-key-part part (cdr cfg)))))

  (define (walk key cfg)
    (debug key " - " cfg)
    (let ((entry (search-key-part (car key) cfg)))
      (debug "entry:" entry)
      (if (eq? entry #f)
	  'undef
	  (if (null? (cdr key))
	      (if (null? (caddr entry))
		  'undef
		  (caaddr entry))
	      (walk (cdr key) (cadr entry))))))

  (walk key cfg))



(define (%scfg-get proc cfg key)
  (internal-scfg-get (car cfg) (if (symbol? key)
				   (list key)
				   key)))

(define (scfg-get cfg key . default-value)
  (if (null? default-value)
      (cfg key)
      (cfg key #t (car default-value))))

;;;;;;;;;;;; scfg-rm!  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (key-equal? k1 k2)
  (if (null? k1)
      (null? k2)
      (if (null? k2)
	  #f
	  (if (equal? (car k1) (car k2))
	      (key-equal? (cdr k1) (cdr k2))
	      #f))))

(define (%scfg-rm proc cfg key)
  (let ((ncfg (list (list))))
    (for-each (lambda (keyval)
		(if (not (eq? keyval #f))
		    (%scfg-set! proc ncfg (car keyval) (cadr keyval))))
	      (scfg-map (lambda (skey val)
			  (if (key-equal? skey key)
			      #f
			      (list skey val))) proc))
    (set-car! cfg (car ncfg))
    proc
    ))
	      

(define (scfg-rm! cfg key)
  (if (symbol? key)
      (cfg '%scfg-rm (list key))
      (cfg '%scfg-rm key)))

;;;;;;;;;;;; scfg-new ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (stream-in proc fh)
  (let ((config (read fh)))
    (let ((cfg (list (list))))
      (for-each (lambda (entry)
		  (debug "stream-in:" entry)
		  (%scfg-set! proc cfg (car entry) (cadr entry)))
		config)
      cfg)))

(define (scfg-new . _filename)
  (let ((filename (if (null? _filename)
		      ""
		      (car _filename))))
    (let ((fh (if (null? _filename)
		  (open-input-string "()")
		  (if (file-exists? filename)
		      (open-input-file filename)
		      (open-input-string "()")))))
      (let ((proc #f))
	(let ((cfg (stream-in proc fh)))
      (close-input-port fh)
	  (%scfg-set! proc cfg '( %scfg filename ) filename)
	  (%scfg-set! proc cfg '( %scfg version ) "$Id: scfg.scm,v 1.2 2006/05/27 17:38:02 hoesterholt Exp $")
	  (set! proc
		(lambda (key . value)
		  (cond
		   ((eq? key '%scfg-save) 
		    (apply %scfg-save proc (cons cfg value)))
		   ((eq? key '%scfg-map)
		    (%scfg-map proc (car value) cfg))
		   ((eq? key '%scfg-rm)
		    (%scfg-rm proc cfg (car value)))
		   (else
		    (if (null? value)
			(%scfg-get proc cfg key)
			(if (null? (cdr value))
			    (%scfg-set! proc cfg key (car value))
			    (let ((val (%scfg-get proc cfg key)))
			      (if (eq? val 'undef)
				  (begin
				    (%scfg-set! proc cfg key (cadr value))
				    (cadr value))
				  val))))))))
	  proc)))))

;;;;;;;;;;;; scfg-save ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (stream-out proc cfg fh)
  (display "(\n" fh)
  (for-each 
   (lambda (keyval)
     (display "  " fh)
     (write keyval fh)
     (newline fh))
   (%scfg-map proc 
	      (lambda (key value)
		(list key value))
	      cfg))
  (display ")\n" fh))

(define (%scfg-save proc cfg . filename)
  (let ((filen (if (null? filename)
		   (%scfg-get proc cfg '(%scfg filename))
		   (car filename))))

    (debug "%scfg-save:filename=" filename)
    (debug "%scfg-save:filename=" (%scfg-get proc cfg '(%scfg filename)) )
    (let ((fh (open-output-file filen 'truncate/replace)))
      (stream-out proc cfg fh)
      (close-output-port fh)

      (debug "%scfg-save " proc cfg filename)
      (if (not (null? filename))
	  (%scfg-set! proc cfg '(%scfg filename) (car filename)))

      cfg)))

(define (scfg-save cfg . filename)
  (apply cfg (cons '%scfg-save filename))
  cfg)


(define (scfg-filename cfg)
  (scfg-get cfg '(%scfg filename)))

;;;;;;;;;;;; scfg-multi-get/set ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Provide functionality to have concurrent setting/getting of preferences
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PROVIDE LOCKING HERE!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (scfg-multi-get cfg key . default)
  (if (null? default)
      (scfg-get cfg key)
      (scfg-get cfg key (car default))))

(define (scfg-multi-set! cfg key value)
  (scfg-set! cfg key value)
  (scfg-save cfg))

)