[bknr-cvs] r2185 - in branches/trunk-reorg: . datastore/experimental/xml-schema datastore/experimental/xml-schema/examples
bknr at bknr.net
bknr at bknr.net
Thu Oct 4 16:18:54 UTC 2007
Author: hhubner
Date: 2007-10-04 12:18:54 -0400 (Thu, 04 Oct 2007)
New Revision: 2185
Added:
branches/trunk-reorg/datastore/
branches/trunk-reorg/web/
Removed:
branches/trunk-reorg/bknr-web/
branches/trunk-reorg/bknr/
Modified:
branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema.xml
branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema2.xml
branches/trunk-reorg/datastore/experimental/xml-schema/xml-schema.lisp
Log:
checkpoint
Copied: branches/trunk-reorg/datastore (from rev 2184, branches/trunk-reorg/bknr)
Modified: branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema.xml
===================================================================
--- branches/trunk-reorg/bknr/experimental/xml-schema/examples/test-schema.xml 2007-10-04 15:50:09 UTC (rev 2184)
+++ branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema.xml 2007-10-04 16:18:54 UTC (rev 2185)
@@ -1,65 +1,65 @@
-<?xml version="1.0"?>
-<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema">
- <xs:element name="name" type="xs:string"/>
- <xs:element name="qualification" type="xs:string"/>
- <xs:element name="born" type="xs:date"/>
- <xs:element name="dead" type="xs:date"/>
- <xs:element name="isbn" type="xs:string"/>
- <xs:attribute name="id" type="xs:ID"/>
- <xs:attribute name="available" type="xs:boolean"/>
- <xs:attribute name="lang" type="xs:language"/>
-
- <xs:element name="title">
- <xs:complexType>
- <xs:simpleContent>
- <xs:extension base="xs:string">
- <xs:attribute ref="lang"/>
- </xs:extension>
- </xs:simpleContent>
- </xs:complexType>
- </xs:element>
-
- <xs:element name="library">
- <xs:complexType>
- <xs:sequence>
- <xs:element ref="book" maxOccurs="unbounded"/>
- </xs:sequence>
- </xs:complexType>
- </xs:element>
-
- <xs:element name="author">
- <xs:complexType>
- <xs:sequence>
- <xs:element ref="name"/>
- <xs:element ref="born"/>
- <xs:element ref="dead" minOccurs="0"/>
- </xs:sequence>
- <xs:attribute ref="id"/>
- </xs:complexType>
- </xs:element>
-
- <xs:element name="book">
- <xs:complexType>
- <xs:sequence>
- <xs:element ref="isbn"/>
- <xs:element ref="title"/>
- <xs:element ref="author" minOccurs="0" maxOccurs="unbounded"/>
- <xs:element ref="character" minOccurs="0" maxOccurs="unbounded"/>
- </xs:sequence>
- <xs:attribute ref="id"/>
- <xs:attribute ref="available"/>
- </xs:complexType>
- </xs:element>
-
- <xs:element name="character">
- <xs:complexType>
- <xs:sequence>
- <xs:element ref="name"/>
- <xs:element ref="born"/>
- <xs:element ref="qualification"/>
- </xs:sequence>
- <xs:attribute ref="id"/>
- </xs:complexType>
- </xs:element>
-
+<?xml version="1.0"?>
+<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema">
+ <xs:element name="name" type="xs:string"/>
+ <xs:element name="qualification" type="xs:string"/>
+ <xs:element name="born" type="xs:date"/>
+ <xs:element name="dead" type="xs:date"/>
+ <xs:element name="isbn" type="xs:string"/>
+ <xs:attribute name="id" type="xs:ID"/>
+ <xs:attribute name="available" type="xs:boolean"/>
+ <xs:attribute name="lang" type="xs:language"/>
+
+ <xs:element name="title">
+ <xs:complexType>
+ <xs:simpleContent>
+ <xs:extension base="xs:string">
+ <xs:attribute ref="lang"/>
+ </xs:extension>
+ </xs:simpleContent>
+ </xs:complexType>
+ </xs:element>
+
+ <xs:element name="library">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element ref="book" maxOccurs="unbounded"/>
+ </xs:sequence>
+ </xs:complexType>
+ </xs:element>
+
+ <xs:element name="author">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element ref="name"/>
+ <xs:element ref="born"/>
+ <xs:element ref="dead" minOccurs="0"/>
+ </xs:sequence>
+ <xs:attribute ref="id"/>
+ </xs:complexType>
+ </xs:element>
+
+ <xs:element name="book">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element ref="isbn"/>
+ <xs:element ref="title"/>
+ <xs:element ref="author" minOccurs="0" maxOccurs="unbounded"/>
+ <xs:element ref="character" minOccurs="0" maxOccurs="unbounded"/>
+ </xs:sequence>
+ <xs:attribute ref="id"/>
+ <xs:attribute ref="available"/>
+ </xs:complexType>
+ </xs:element>
+
+ <xs:element name="character">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element ref="name"/>
+ <xs:element ref="born"/>
+ <xs:element ref="qualification"/>
+ </xs:sequence>
+ <xs:attribute ref="id"/>
+ </xs:complexType>
+ </xs:element>
+
</xs:schema>
\ No newline at end of file
Modified: branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema2.xml
===================================================================
--- branches/trunk-reorg/bknr/experimental/xml-schema/examples/test-schema2.xml 2007-10-04 15:50:09 UTC (rev 2184)
+++ branches/trunk-reorg/datastore/experimental/xml-schema/examples/test-schema2.xml 2007-10-04 16:18:54 UTC (rev 2185)
@@ -1,47 +1,47 @@
-<?xml version="1.0"?>
-<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema">
- <xs:element name="library">
- <xs:complexType>
- <xs:sequence>
- <xs:element name="book" maxOccurs="unbounded">
- <xs:complexType>
- <xs:sequence>
- <xs:element name="isbn" type="xs:integer"/>
- <xs:element name="title">
- <xs:complexType>
- <xs:simpleContent>
- <xs:extension base="xs:string">
- <xs:attribute name="lang" type="xs:language"/>
- </xs:extension>
- </xs:simpleContent>
- </xs:complexType>
- </xs:element>
- <xs:element name="author" minOccurs="0" maxOccurs="unbounded">
- <xs:complexType>
- <xs:sequence>
- <xs:element name="name" type="xs:string"/>
- <xs:element name="born" type="xs:date"/>
- <xs:element name="dead" type="xs:date"/>
- </xs:sequence>
- <xs:attribute name="id" type="xs:ID"/>
- </xs:complexType>
- </xs:element>
- <xs:element name="character" minOccurs="0" maxOccurs="unbounded">
- <xs:complexType>
- <xs:sequence>
- <xs:element name="name" type="xs:string"/>
- <xs:element name="born" type="xs:date"/>
- <xs:element name="qualification" type="xs:string"/>
- </xs:sequence>
- <xs:attribute name="id" type="xs:ID"/>
- </xs:complexType>
- </xs:element>
- </xs:sequence>
- <xs:attribute name="id" type="xs:ID"/>
- <xs:attribute name="available" type="xs:boolean"/>
- </xs:complexType>
- </xs:element>
- </xs:sequence>
- </xs:complexType>
- </xs:element>
-</xs:schema>
+<?xml version="1.0"?>
+<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema">
+ <xs:element name="library">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element name="book" maxOccurs="unbounded">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element name="isbn" type="xs:integer"/>
+ <xs:element name="title">
+ <xs:complexType>
+ <xs:simpleContent>
+ <xs:extension base="xs:string">
+ <xs:attribute name="lang" type="xs:language"/>
+ </xs:extension>
+ </xs:simpleContent>
+ </xs:complexType>
+ </xs:element>
+ <xs:element name="author" minOccurs="0" maxOccurs="unbounded">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element name="name" type="xs:string"/>
+ <xs:element name="born" type="xs:date"/>
+ <xs:element name="dead" type="xs:date"/>
+ </xs:sequence>
+ <xs:attribute name="id" type="xs:ID"/>
+ </xs:complexType>
+ </xs:element>
+ <xs:element name="character" minOccurs="0" maxOccurs="unbounded">
+ <xs:complexType>
+ <xs:sequence>
+ <xs:element name="name" type="xs:string"/>
+ <xs:element name="born" type="xs:date"/>
+ <xs:element name="qualification" type="xs:string"/>
+ </xs:sequence>
+ <xs:attribute name="id" type="xs:ID"/>
+ </xs:complexType>
+ </xs:element>
+ </xs:sequence>
+ <xs:attribute name="id" type="xs:ID"/>
+ <xs:attribute name="available" type="xs:boolean"/>
+ </xs:complexType>
+ </xs:element>
+ </xs:sequence>
+ </xs:complexType>
+ </xs:element>
+</xs:schema>
Modified: branches/trunk-reorg/datastore/experimental/xml-schema/xml-schema.lisp
===================================================================
--- branches/trunk-reorg/bknr/experimental/xml-schema/xml-schema.lisp 2007-10-04 15:50:09 UTC (rev 2184)
+++ branches/trunk-reorg/datastore/experimental/xml-schema/xml-schema.lisp 2007-10-04 16:18:54 UTC (rev 2185)
@@ -1,197 +1,197 @@
-(in-package :cl-user)
-
-;;; general helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro awhen (test-form &rest then-forms)
- `(let ((it ,test-form))
- (when it , at then-forms)))
-
-(defmacro aif (pred then-form &optional else-form)
- `(let ((it ,pred)) (if it ,then-form ,else-form)))
-
-(defun string-null (string)
- (string-equal string ""))
-
-(defconstant +whitespace-chars+
- '(#\Space #\Newline #\Tab #\Linefeed))
-
-(defun whitespace-char-p (c)
- (member c +whitespace-chars+))
-
-(defun whitespace-p (c-or-s)
- (cond ((stringp c-or-s)
- (every #'whitespace-char-p c-or-s))
- ((characterp c-or-s)
- (whitespace-char-p c-or-s))
- (t nil)))
-
-(defun make-keyword-from-string (string)
- (if (keywordp string)
- string
- (nth-value 0 (intern (string-upcase
- (substitute-if #\- #'(lambda (char)
- (or (whitespace-char-p char)
- (eql #\: char)))
- string)) 'keyword))))
-
-
-;;; cxml helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun child-elements (node)
- (coerce (remove-if-not #'dom:element-p (dom:child-nodes node)) 'list))
-
-(defmacro with-attributes (attributes node &rest body)
- `(let ,(loop for attr in attributes
- when (symbolp attr)
- collect `(,attr (dom:get-attribute ,node ,(string-downcase (symbol-name attr))))
- when (listp attr)
- collect `(,(car attr) (dom:get-attribute ,node ,(cadr attr))))
- ,@(loop for attr in attributes
- when (symbolp attr)
- collect `(when (string-null ,attr)
- (error ,(format nil "Attribute ~S is empty."
- (string-downcase (symbol-name attr)))))
- when (listp attr)
- collect `(when (string-null ,(car attr))
- (error ,(format nil "Attribute ~S is empty." (cadr attr)))))
- , at body))
-
-
-;;; xml schema parser ;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; element and attribute environment
-
-(defvar *xml-schema-envs* nil
- "This special variables holds the list of the current xml schema
-element definition environments. Environments can be nested, the list
-holds them in top to bottom order (the toplevel environment is first.")
-
-(defun get-xml-schema-ref (ref)
- "Get the definition of REF from the current environment stack."
- (dolist (env *xml-schema-envs*)
- (awhen (gethash ref env)
- (return it))))
-
-(defun (setf get-xml-schema-ref) (newvalue ref)
- "Set the definition of REF in the current environment."
- (let ((env (first *xml-schema-envs*)))
- (awhen (gethash ref env)
- (error "There already is an XML Schema element named ~A: ~A." ref it))
- (setf (gethash ref env) newvalue)))
-
-;;; xml schema types
-
-(defgeneric parse-xs-type (type elt)
- (:documentation "Parse ELT according to TYPE. TYPE can be a keyword
-to identify base datatypes, or a class derived from XS-TYPE."))
-
-(defmacro define-xs-type (name (elt) &rest body)
- "Define a base XML Schema type, named by a keyword. For example,
-\"xs:string\" is identified by :XS-STRING."
- (let ((n (gensym)))
- `(defmethod parse-xs-type (,(if (keywordp name)
- `(,n (eql ,name))
- name)
- ,elt)
- , at body)))
-
-(defmacro define-xs-type-error (name (elt) &rest body)
- "Define the default error function called when ELT could not be
-parsed as a value of type NAME."
- `(define-xs-type ,name ((,elt t))
- , at body))
-
-;;; Einfach XML Schema typen, wie primitive Types, einfach Elements
-;;; und Attributes werden direkt zu Lisp primitive geparst.
-
-(define-xs-type :xs-string ((elt dom-impl::text))
- (dom:node-value elt))
-
-(define-xs-type :xs-string ((elt dom-impl::node))
- (let ((children (dom:child-nodes elt)))
- (if (and (= (length children) 1)
- (dom:text-node-p (aref children 0)))
- (dom:node-value (aref children 0))
- "")))
-
-(define-xs-type-error :xs-string (elt)
- (error "~s could not be parsed as xs:string." elt))
-
-(defclass xs-elt ()
- ((name :initarg :name :initform nil :reader xs-elt-name)
- (type :initarg :type :initform nil :reader xs-elt-type)))
-
-(defun create-xs-elt (node)
- (unless (= (length (dom:child-nodes node)) 0)
- (error "~a is not a simple XML Scheme element node." node))
- (with-attributes (name type) node
- (setf (get-xml-schema-ref name)
- (make-instance 'xs-elt
- :name name
- :type (make-keyword-from-string type)))))
-
-(defclass xs-attribute (xs-elt)
- ())
-
-(defun create-xs-attribute (node)
- (unless (= (length (dom:child-nodes node)) 0)
- (error "~a is not an XML Scheme attribute node." node))
- (with-attributes (name type) node
- (setf (get-xml-schema-ref name)
- (make-instance 'xs-attribute
- :name name
- :type (make-keyword-from-string type)))))
-
-(define-xs-type (type xs-elt) (elt)
- (parse-xs-type (xs-elt-type type) elt))
-
-
-(defclass xs-complex-type (xs-type)
- ((attrs :initarg :attrs :reader xs-ctype-attrs)
- (children :initarg :children :reader xs-ctype-children)
- (content :initarg :content :reader xs-ctype-content)))
-
-
-(defclass xs-element ()
- ((name :initarg :name :reader xs-type-name)
- (type :initarg :type :reader xs-type-type)))
-
-(defun xs-attribute-p (node)
- (string-equal (dom:node-name node) "xs:attribute"))
-
-(defun xs-element-p (node)
- (string-equal (dom:node-name node) "xs:element"))
-
-(defun xs-simple-type-p (node)
- (or (xs-attribute-p node)
- (and (xs-element-p node)
- (null (child-elements node)))))
-
-(defun xs-complex-type-p (node)
- (let ((children (child-elements node)))
- (and (xs-element-p node)
- (not (null children))
- (let ((child (first children)))
- (string-equal (dom:node-name node)
- "xs:complexType")))))
-
-(defun parse-schema-node (elt)
- (cond ((xs-attribute-p elt)
- (create-xs-attribute elt))
- ((xs-simple-type-p elt)
- (create-xs-simple-type elt))
- #+nil
- ((xs-complex-type-p elt)
- (create-xs-complex-type elt))
- (t (error "Unknown top-level XML Schema node: ~A." (dom:node-name elt)))))
-
-(defun parse-schema-file (filename)
- "Returns the toplevel XML schema environment."
- (let* ((dom (cxml:parse-file filename (dom:make-dom-builder)))
- (root (dom:document-element dom))
- (*xml-schema-envs* (list (make-hash-table))))
- (unless (string-equal (dom:node-name root) "xs:schema")
- (error "Document is not an XML Schema document."))
- (dolist (elt (child-elements root))
- (parse-schema-node elt))
+(in-package :cl-user)
+
+;;; general helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro awhen (test-form &rest then-forms)
+ `(let ((it ,test-form))
+ (when it , at then-forms)))
+
+(defmacro aif (pred then-form &optional else-form)
+ `(let ((it ,pred)) (if it ,then-form ,else-form)))
+
+(defun string-null (string)
+ (string-equal string ""))
+
+(defconstant +whitespace-chars+
+ '(#\Space #\Newline #\Tab #\Linefeed))
+
+(defun whitespace-char-p (c)
+ (member c +whitespace-chars+))
+
+(defun whitespace-p (c-or-s)
+ (cond ((stringp c-or-s)
+ (every #'whitespace-char-p c-or-s))
+ ((characterp c-or-s)
+ (whitespace-char-p c-or-s))
+ (t nil)))
+
+(defun make-keyword-from-string (string)
+ (if (keywordp string)
+ string
+ (nth-value 0 (intern (string-upcase
+ (substitute-if #\- #'(lambda (char)
+ (or (whitespace-char-p char)
+ (eql #\: char)))
+ string)) 'keyword))))
+
+
+;;; cxml helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun child-elements (node)
+ (coerce (remove-if-not #'dom:element-p (dom:child-nodes node)) 'list))
+
+(defmacro with-attributes (attributes node &rest body)
+ `(let ,(loop for attr in attributes
+ when (symbolp attr)
+ collect `(,attr (dom:get-attribute ,node ,(string-downcase (symbol-name attr))))
+ when (listp attr)
+ collect `(,(car attr) (dom:get-attribute ,node ,(cadr attr))))
+ ,@(loop for attr in attributes
+ when (symbolp attr)
+ collect `(when (string-null ,attr)
+ (error ,(format nil "Attribute ~S is empty."
+ (string-downcase (symbol-name attr)))))
+ when (listp attr)
+ collect `(when (string-null ,(car attr))
+ (error ,(format nil "Attribute ~S is empty." (cadr attr)))))
+ , at body))
+
+
+;;; xml schema parser ;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; element and attribute environment
+
+(defvar *xml-schema-envs* nil
+ "This special variables holds the list of the current xml schema
+element definition environments. Environments can be nested, the list
+holds them in top to bottom order (the toplevel environment is first.")
+
+(defun get-xml-schema-ref (ref)
+ "Get the definition of REF from the current environment stack."
+ (dolist (env *xml-schema-envs*)
+ (awhen (gethash ref env)
+ (return it))))
+
+(defun (setf get-xml-schema-ref) (newvalue ref)
+ "Set the definition of REF in the current environment."
+ (let ((env (first *xml-schema-envs*)))
+ (awhen (gethash ref env)
+ (error "There already is an XML Schema element named ~A: ~A." ref it))
+ (setf (gethash ref env) newvalue)))
+
+;;; xml schema types
+
+(defgeneric parse-xs-type (type elt)
+ (:documentation "Parse ELT according to TYPE. TYPE can be a keyword
+to identify base datatypes, or a class derived from XS-TYPE."))
+
+(defmacro define-xs-type (name (elt) &rest body)
+ "Define a base XML Schema type, named by a keyword. For example,
+\"xs:string\" is identified by :XS-STRING."
+ (let ((n (gensym)))
+ `(defmethod parse-xs-type (,(if (keywordp name)
+ `(,n (eql ,name))
+ name)
+ ,elt)
+ , at body)))
+
+(defmacro define-xs-type-error (name (elt) &rest body)
+ "Define the default error function called when ELT could not be
+parsed as a value of type NAME."
+ `(define-xs-type ,name ((,elt t))
+ , at body))
+
+;;; Einfach XML Schema typen, wie primitive Types, einfach Elements
+;;; und Attributes werden direkt zu Lisp primitive geparst.
+
+(define-xs-type :xs-string ((elt dom-impl::text))
+ (dom:node-value elt))
+
+(define-xs-type :xs-string ((elt dom-impl::node))
+ (let ((children (dom:child-nodes elt)))
+ (if (and (= (length children) 1)
+ (dom:text-node-p (aref children 0)))
+ (dom:node-value (aref children 0))
+ "")))
+
+(define-xs-type-error :xs-string (elt)
+ (error "~s could not be parsed as xs:string." elt))
+
+(defclass xs-elt ()
+ ((name :initarg :name :initform nil :reader xs-elt-name)
+ (type :initarg :type :initform nil :reader xs-elt-type)))
+
+(defun create-xs-elt (node)
+ (unless (= (length (dom:child-nodes node)) 0)
+ (error "~a is not a simple XML Scheme element node." node))
+ (with-attributes (name type) node
+ (setf (get-xml-schema-ref name)
+ (make-instance 'xs-elt
+ :name name
+ :type (make-keyword-from-string type)))))
+
+(defclass xs-attribute (xs-elt)
+ ())
+
+(defun create-xs-attribute (node)
+ (unless (= (length (dom:child-nodes node)) 0)
+ (error "~a is not an XML Scheme attribute node." node))
+ (with-attributes (name type) node
+ (setf (get-xml-schema-ref name)
+ (make-instance 'xs-attribute
+ :name name
+ :type (make-keyword-from-string type)))))
+
+(define-xs-type (type xs-elt) (elt)
+ (parse-xs-type (xs-elt-type type) elt))
+
+
+(defclass xs-complex-type (xs-type)
+ ((attrs :initarg :attrs :reader xs-ctype-attrs)
+ (children :initarg :children :reader xs-ctype-children)
+ (content :initarg :content :reader xs-ctype-content)))
+
+
+(defclass xs-element ()
+ ((name :initarg :name :reader xs-type-name)
+ (type :initarg :type :reader xs-type-type)))
+
+(defun xs-attribute-p (node)
+ (string-equal (dom:node-name node) "xs:attribute"))
+
+(defun xs-element-p (node)
+ (string-equal (dom:node-name node) "xs:element"))
+
+(defun xs-simple-type-p (node)
+ (or (xs-attribute-p node)
+ (and (xs-element-p node)
+ (null (child-elements node)))))
+
+(defun xs-complex-type-p (node)
+ (let ((children (child-elements node)))
+ (and (xs-element-p node)
+ (not (null children))
+ (let ((child (first children)))
+ (string-equal (dom:node-name node)
+ "xs:complexType")))))
+
+(defun parse-schema-node (elt)
+ (cond ((xs-attribute-p elt)
+ (create-xs-attribute elt))
+ ((xs-simple-type-p elt)
+ (create-xs-simple-type elt))
+ #+nil
+ ((xs-complex-type-p elt)
+ (create-xs-complex-type elt))
+ (t (error "Unknown top-level XML Schema node: ~A." (dom:node-name elt)))))
+
+(defun parse-schema-file (filename)
+ "Returns the toplevel XML schema environment."
+ (let* ((dom (cxml:parse-file filename (dom:make-dom-builder)))
+ (root (dom:document-element dom))
+ (*xml-schema-envs* (list (make-hash-table))))
+ (unless (string-equal (dom:node-name root) "xs:schema")
+ (error "Document is not an XML Schema document."))
+ (dolist (elt (child-elements root))
+ (parse-schema-node elt))
(pop *xml-schema-envs*)))
\ No newline at end of file
Copied: branches/trunk-reorg/web (from rev 2184, branches/trunk-reorg/bknr-web)
More information about the Bknr-cvs
mailing list