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")))) +