Author: ehuelsmann
Date: Sun Jan 6 15:59:07 2008
New Revision: 1
Added:
branches/
developer-resources/
public_html/
tags/
trunk/
trunk/config.lisp
trunk/package.lisp
trunk/parser.lisp
trunk/py-configparser.asd
Log:
Added: trunk/config.lisp
==============================================================================
--- (empty file)
+++ trunk/config.lisp Sun Jan 6 15:59:07 2008
@@ -0,0 +1,293 @@
+
+(cl:in-package :py-configparser)
+
+;; The conditions (errors)
+
+(define-condition configparser-error (error) ())
+
+;; Errors for the configuration management side
+(define-condition config-error (configparser-error) ())
+(define-condition no-section-error (config-error) ())
+(define-condition duplicate-section-error (config-error) ())
+(define-condition no-option-error (config-error) ())
+(define-condition interpolation-error (config-error) ())
+(define-condition interpolation-depth-error (interpolation-error) ())
+(define-condition interpolation-missing-option-error (interpolation-error) ())
+(define-condition interpolation-syntax-error (interpolation-error) ())
+
+
+;;
+;; Configuration storage and management routines
+;;
+
+
+;; The structures
+;; Note: because ABCL has issues with its CLOS support
+;; (as per 1-1-2008), we use structures below to
+;; be maximally portable.
+
+
+(defstruct section
+ name
+ options)
+
+(defstruct config
+ (defaults (make-section :name "DEFAULT"))
+ sections
+ (option-name-transform-fn #'string-downcase)
+ (section-name-transform-fn #'identity))
+
+(defun norm-option-name (config option-name)
+ (funcall (config-option-name-transform-fn config) option-name))
+
+(defun norm-section-name (config section-name)
+ (funcall (config-section-name-transform-fn config) section-name))
+
+(defun %validate-section-name (name)
+ (when (or (= 0 (length name))
+ (find #\] name)
+ (find #\Newline name)
+ (find #\Return name))
+ (error 'no-section-error)) ;; Invalid section name, signal so.
+ name)
+
+(defun %validate-option-name (name)
+ (when (or (= 0 (length name))
+ (eql (aref name 0) #\[)
+ (find #\Space name)
+ (find #\Tab name)
+ (find #\Return name)
+ (find #\Newline name))
+ (error 'no-option-error));; No such option error
+ name)
+
+;; non-API
+(defun %get-section (config section-name)
+ (if (string= "DEFAULT" section-name)
+ (config-defaults config)
+ (let* ((norm-section-name (norm-section-name config section-name))
+ (section (find norm-section-name (config-sections config)
+ :key #'section-name
+ :test #'string=)))
+ (unless section
+ (error 'no-section-error)) ;; no-such-section error
+ section)))
+
+;; non-API
+(defun %get-option (config section-name option-name if-does-not-exist)
+ (let* ((section (%get-section config section-name))
+ (norm-option (norm-option-name config option-name))
+ (option (assoc norm-option
+ (section-options section)
+ :test #'string=)))
+ (if (null option)
+ (if (eq if-does-not-exist :error)
+ (error 'no-option-error) ;; no such option error
+ (values (car (push (list (%validate-option-name option-name))
+ (section-options section)))
+ section))
+ (values option section))))
+
+;;
+;; The API
+;;
+
+(defun defaults (config)
+ "Returns an alist containing instance wide defaults, where the
+elements are 2-element dotted lists: the CDR is the value
+associated with the key."
+ (section-options (config-defaults config)))
+
+(defun sections (config)
+ "Returns a list of names of defined sections."
+ (mapcar #'section-name (config-sections config)))
+
+(defun has-section-p (config section-name)
+ "Returns `NIL' when the section is not added to the config yet,
+some other value if it is."
+ (handler-case
+ (%get-section config section-name)
+ (no-section-error () nil)))
+
+(defun add-section (config section-name)
+ "Adds a new section to the config.
+
+If the section exists, the `duplicate-section-error' is raised."
+ (%validate-section-name section-name)
+ (let ((norm-section-name (funcall (config-section-name-transform-fn config)
+ section-name)))
+ (when (has-section-p config section-name)
+ (error 'duplicate-section-error))
+ (car (push (make-section :name norm-section-name)
+ (config-sections config)))))
+
+(defun options (config section-name)
+ "Returns a list of option names which are defined in the given section."
+ (let ((section (%get-section config section-name)))
+ (mapcar #'first (section-options section))))
+
+(defun has-option-p (config section-name option-name)
+ "Returns a generalised boolean with a value of `NIL' when
+the specified option does not exist in the specified section
+and some other value otherwise."
+ (handler-case
+ (%get-option config section-name option-name :error)
+ (no-option-error () nil)))
+
+;; non-API
+(defun %extract-replacement (option-value)
+ ;; Returns: (VALUES replacement-option start end) or NIL
+ (let ((%-pos (position #\% option-value)))
+ (when (and %-pos
+ (< (+ 3 %-pos) (length option-value))
+ (eql (aref option-value (1+ %-pos)) #\( ))
+ (let ((paren-pos (position #\) option-value :start %-pos)))
+ (unless (and paren-pos
+ (< (1+ paren-pos) (length option-value))
+ (eql (aref option-value (1+ paren-pos)) #\s))
+ (error 'interpolation-syntax-error))
+ ;; syntax error: %(..)s is minimally required
+ (when (<= 0 (- paren-pos %-pos 2))
+ (let ((replacement-name
+ (make-array (- paren-pos %-pos 2)
+ :element-type (array-element-type option-value)
+ :displaced-to option-value
+ :displaced-index-offset (+ 2 %-pos))))
+ (when (= 0 (length replacement-name))
+ ;; some preconditions on replacement-name
+ (error 'interpolation-syntax-error))
+ (values replacement-name %-pos (1+ paren-pos))))))))
+
+;; non-API
+(defun %option-value (config section option-name &key defaults)
+ (if (string= option-name "__name__")
+ (section-name section)
+ (let* ((norm-option-name (norm-option-name config option-name)))
+ (labels ((get-value (repositories)
+ (when (null repositories)
+ (error 'interpolation-missing-option-error))
+ ;; no such option error
+ (let ((option (has-option-p config (section-name section)
+ option-name)))
+ (if option
+ (cdr option)
+ (get-value (cdr repositories))))))
+ (get-value (list (section-options section)
+ defaults
+ (defaults config)))))))
+
+;; non-API
+(defun %expand-option-value (config section option-value defaults
+ &optional dependees)
+ (multiple-value-bind
+ (replacement-name start end)
+ (%extract-replacement option-value)
+ (unless replacement-name
+ ;; nothing to do here...
+ (return-from %expand-option-value option-value))
+
+ (let ((norm-replacement (norm-option-name config replacement-name))
+ (replacement-value (%option-value config section
+ replacement-name
+ :defaults defaults)))
+ (when (member norm-replacement dependees :test #'string=)
+ (error 'interpolation-depth-error)) ;; recursive dependency...
+ (%expand-option-value
+ config
+ section
+ (concatenate 'string
+ (subseq option-value 0 start)
+ (%expand-option-value config
+ section
+ replacement-value
+ defaults
+ (cons norm-replacement dependees))
+ (subseq option-value (1+ end) (length option-value)))
+ defaults
+ dependees))))
+
+(defun get-option (config section-name option-name
+ &key (expand t) defaults type)
+ "Returns the value of the specified option in the specified section.
+
+If `expand' is `NIL', any options which depend on other options
+won't be expanded and the raw configuration value is returned.
+
+When `defaults' is an alist of which the elements are dotted lists of
+key/value pairs, these values are used in the expansion of option values.
+
+`type' may be one of `:boolean', `:number' or it may remain unspecified."
+ (multiple-value-bind
+ (option section)
+ (%get-option config section-name option-name :error)
+ (flet ((convert-boolean (v)
+ (cond
+ ((member v '("1" "yes" "true" "on") :test #'string=)
+ T)
+ ((member v '("0" "no" "false" "off") :test #'string=)
+ NIL)
+ (t
+ (error 'not-a-boolean))))
+ (convert-number (v)
+ (parse-number:parse-number v)))
+ (let ((string-value
+ (if expand
+ (%expand-option-value config
+ section (cdr option)
+ (list option-name))
+ (cdr option))))
+ (cond
+ ((eq type :boolean)
+ (convert-boolean string-value))
+ ((eq type :number)
+ (convert-number string-value))
+ ((null type)
+ string-value)
+ (t
+ (error "Illegal `type' parameter value.")))))))
+
+(defun set-option (config section-name option-name value)
+ "Sets the value of the specified option in the specified section.
+
+If the section does not exist, a `no-section-error' is raised. If the
+option does not exist, it is created."
+ (let ((option (%get-option config section-name option-name :create)))
+ (setf (cdr option) value)))
+
+(defun items (config section-name &key (expand t) defaults)
+ "Returns an alist of which the items are dotted lists of key/value
+pairs being the option names and values specified in the given section.
+
+When `expand' is `NIL', options are returned in raw form. Otherwise
+option values are expanded.
+
+The definition of `defaults' is the same as for `get-option'."
+ (let ((section (get-section config section-name)))
+ (if expand
+ (mapcar #'(lambda (x)
+ (cons (car x) (get-option p section-name
+ (cdr x) ;; option-name
+ :expand t
+ :defaults defaults)))
+ (section-options section))
+ (section-options section))))
+
+(defun remove-option (config section-name option-name)
+ "Remove the specified option from the given section."
+ (multiple-value-bind
+ (option section)
+ (%get-option config section-name option-name :error)
+ (setf (section-options section)
+ (remove option (section-options section)))))
+
+(defun remove-section (config section-name)
+ "Remove the specified section.
+
+In case the section name equals the magic name `DEFAULT',
+an error is raised, since this section can't be removed."
+ (when (string= section-name "DEFAULT")
+ (error 'no-section-error)) ;; no such section error
+ (let ((section (%get-section config section-name)))
+ (setf (config-sections config)
+ (remove section (config-sections config)))))
+
Added: trunk/package.lisp
==============================================================================
--- (empty file)
+++ trunk/package.lisp Sun Jan 6 15:59:07 2008
@@ -0,0 +1,54 @@
+
+;; This package is actuall two things:
+;; 1) a configuration management utility
+;; 2) a configuration file parser/writer in the .INI format
+;;
+;; But in the Python module this distinction hasn't been implemented
+;; this stringently, meaning we're stuck to the current naming scheme.
+
+;; There's no reason however that you can't create your own format
+;; and parse that, storing it in the config object as defined in this
+;; package. (However, if you already use this module, you might as well
+;; use the INI format as persistent format.)
+
+
+(cl:defpackage #:py-configparser
+ (:use #:cl)
+ (:export
+ ;; common condition class
+ #:configparser-error
+
+ ;; Configuration management
+ ;; Error classes
+ #:no-section-erorr
+ #:duplicate-section-error
+ #:no-option-error
+ #:interpolation-error
+ #:interpolation-depth-error
+ #:interpolation-missing-option-error
+ #:interpolation-syntax-error
+
+ ;; Functions
+ #:make-config
+ #:defaults
+ #:sections
+ #:has-section-p
+ #:add-section
+ #:options
+ #:has-option-p
+ #:get-option
+ #:set-option
+ #:items
+ #:remove-option
+ #:remove-section
+
+ ;; Configuration file parsing
+ ;; Error classes
+ #:parsing-error
+ #:missing-section-header-error
+
+ ;; Functions
+ #:read-stream
+ #:read-files
+ #:write-stream))
+
Added: trunk/parser.lisp
==============================================================================
--- (empty file)
+++ trunk/parser.lisp Sun Jan 6 15:59:07 2008
@@ -0,0 +1,216 @@
+
+(cl:in-package #:py-configparser)
+
+;; Errors for the parsing side
+
+(define-condition parsing-error (configparser-error) ())
+(define-condition missing-section-header-error (parsing-error) ())
+
+
+
+;; The reader
+
+(proclaim '(special *line-no* *current-section* *file-name*
+ *current-input*))
+(proclaim '(inline %read-char %unread-char))
+
+(defun %read-char (stream)
+ (let ((ch (read-char stream nil :eof)))
+ (when (eql ch #\Newline)
+ (incf *line-no*))
+ (if (eq ch :eof) #\Newline ch)))
+
+(defun ensure-section (config section-name)
+ (handler-case
+ (%get-section config section-name)
+ (no-section-error ()
+ (add-section config section-name)))
+ section-name)
+
+(defun is-whitespace (c)
+ (or (eq c #\Space)
+ (eq c #\Tab)
+ (eq c #\Return)))
+
+(defun is-comment-char (c)
+ (or (eq c #\;)
+ (eq c #\#)))
+
+(defun skip-whitespace (s)
+ (loop for c = (%read-char s)
+ while (is-whitespace c)))
+
+(defun skip-emtpy-line (s)
+ (loop for c = (%read-char s)
+ if (eq c #\Newline) do (return)
+ else unless (is-whitespace c)
+ do (error 'parsing-error))) ;; empty line expected
+
+(defun skip-to-eol (s)
+ (loop for c = (%read-char s)
+ until (eq c #\Newline)))
+
+(defun expect-char (s expect &key skip-whitespace)
+ (let ((ch (%read-char s)))
+ (when (and skip-whitespace
+ (is-whitespace ch))
+ (loop for c = (%read-char s)
+ while (is-whitespace c)
+ finally (setf ch c)))
+ (unless (eq ch expect)
+ (error 'parsing-error)) ;; character expect expected, but ch found
+ ch))
+
+(defun expect-one-of (s expect-bag &key skip-whitespace)
+ (let ((ch (%read-char s)))
+ (when (and skip-whitespace
+ (is-whitespace ch))
+ (loop for c = (%read-char s)
+ while (is-whitespace c)
+ finally (setf ch c)))
+ (unless (member ch expect-bag)
+ (error 'parsing-error)) ;; character ch found, but looking for EXPECT-BAG
+ ch))
+
+(defun make-input-buffer (p)
+ (make-array 20 :element-type 'cl:character :fill-pointer 0))
+
+(proclaim '(inline extend-input))
+(defun extend-input (p c)
+ (vector-push-extend c *current-input* 20))
+
+(defun finalize-input (p)
+ (let ((cp *current-input*))
+ (setf *current-input*
+ (make-input-buffer p))
+ cp))
+
+(defun read-section-name (p s)
+ (expect-char s #\[)
+ (loop for c = (%read-char s)
+ if (eq c #\Newline)
+ do (error 'parsing-error) ;; we can't have newlines in section names!
+ else if (eq c #\])
+ do (progn
+ (skip-to-eol s)
+ (return (finalize-input p)))
+ else do (extend-input p c)))
+
+(defun read-option-name (p s)
+ (loop for c = (%read-char s)
+ if (or (eq c #\:)
+ (eq c #\=))
+ do (let ((option-name (finalize-input p)))
+ (when (= 0 (length option-name))
+ (error 'parsing-error)) ;; No option name found
+ (return option-name))
+ else if (is-whitespace c)
+ do (unread-char (expect-one-of s '(#\: #\=) :skip-whitespace t) s)
+ else do (extend-input p c)))
+
+(defun read-option-value (p s &key (leading-white :skip))
+ (let ((leading-mode t)
+ (lead-detected nil))
+ (loop for c = (%read-char s)
+ unless (or (eql c #\Return)
+ (eql c #\Newline))
+ do (if (and leading-mode
+ (is-whitespace c))
+ (setf lead-detected t)
+ (progn
+ (when (and (eq leading-white :fold)
+ leading-mode
+ lead-detected)
+ (extend-input p #\Space))
+ (setf leading-mode nil)
+ (extend-input p c)))
+
+ if (and (eql c #\Newline)
+ (let ((ch (peek-char nil s nil nil)))
+ (or (eql ch #\Space)
+ (eql ch #\Tab))))
+ do (return (read-option-value p s :leading-white :fold))
+ until (eql c #\Newline)
+ finally (return (finalize-input p)))))
+
+(defun reading-driver (p s)
+ (let ((*line-no* 0)
+ (*current-section* nil)
+ (*current-input* (make-input-buffer p)))
+ (loop for c = (peek-char nil s nil :eof)
+ until (eq c :eof)
+ if (eql c #\[)
+ do (setf *current-section*
+ (ensure-section p (read-section-name p s)))
+
+ else if (is-whitespace c)
+ do (skip-empty-line s)
+
+ else if (is-comment-char c)
+ do (skip-to-eol s)
+
+ else if (eql c #\Newline)
+ do (%read-char s) ;; skip over the newline character
+
+ else do (if (null *current-section*)
+ (error 'missing-section-header-error)
+ (set-option p
+ *current-section*
+ (read-option-name p s)
+ (read-option-value p s))))))
+
+;;
+;; The API
+;;
+
+(defun read-files (config filenames)
+ "Parses the files given in the list `filenames', if they exist.
+The list is processed first to last, overwriting any pre-existing
+values with the last value read.
+
+The results are stored in `config' which is modified destructively.
+
+Returns as values the configuration and the list of files actually read."
+ (let (files-read)
+ (dolist (filename (mapcar #'probe-file filenames)
+ (values config files-read))
+ (with-open-file (s filename
+ :direction :input
+ :if-does-not-exist :error)
+ (read-stream config s :stream-name filename))
+ (push filename files-read))))
+
+(defun read-stream (config stream &key (stream-name "an unknown stream"))
+ "Parses the content of `stream' as a configuration file,
+storing any values in `config' which is modified destructively.
+
+This function maps from the python 'readfp()' function."
+ (let ((*file-name* stream-name))
+ (reading-driver config stream)
+ config )
+
+(defun %format-value (value)
+ (if (and (numberp value)
+ (not (integerp value)))
+ (format nil "~,,,,,,'eE" value)
+ value))
+
+(defun write-stream (config stream)
+ "Writes the configuration file corresponding to the
+in-memory config state. Reloading the file
+with `read-stream' or `read-files' will restore config state."
+ (flet ((write-section (section)
+ (format stream "[~a]~%" (section-name section))
+ (format stream "~:{~A = ~{~A~%~}~}~%"
+ (mapcar #'(lambda (option)
+ (list (car option)
+ (list (%format-value (cdr option)))))
+ (section-options section)))))
+ (let ((*print-radix* nil)
+ (*print-base* 10))
+ ;; set the printer output as expected by python
+ (when (defaults config)
+ ;; write the defaults too!!
+ (write-section (config-defaults config)))
+ (mapcar #'write-section (config-sections config)))))
+
Added: trunk/py-configparser.asd
==============================================================================
--- (empty file)
+++ trunk/py-configparser.asd Sun Jan 6 15:59:07 2008
@@ -0,0 +1,20 @@
+
+
+(in-package #:cl-user)
+
+(defpackage #:py-configparser-system
+ (:use #:cl #:asdf))
+
+(in-package #:py-configparser-system)
+
+(defsystem py-configparser
+ :name "py-configparser"
+ :author "Erik Huelsmann"
+ :version "1.0-dev"
+ :license "MIT"
+ :description "Common Lisp implementation of the Python ConfigParser module"
+ :depends-on (#:parse-number)
+ :components ((:file "package")
+ (:file "config" :depends-on ("package"))
+ (:file "parser" :depends-on ("config"))))
+
