[bknr-cvs] r1838 - in branches/xml-class-rework/bknr/src: . data web xml-impex
bknr at bknr.net
bknr at bknr.net
Fri Feb 17 20:52:08 UTC 2006
Author: hhubner
Date: 2006-02-17 14:52:07 -0600 (Fri, 17 Feb 2006)
New Revision: 1838
Modified:
branches/xml-class-rework/bknr/src/bknr-data-impex.asd
branches/xml-class-rework/bknr/src/data/package.lisp
branches/xml-class-rework/bknr/src/data/xml-object.lisp
branches/xml-class-rework/bknr/src/web/menu.lisp
branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp
branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp
branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp
Log:
Commit some more pending changes towards the dtd-less xml-class.
Modified: branches/xml-class-rework/bknr/src/bknr-data-impex.asd
===================================================================
--- branches/xml-class-rework/bknr/src/bknr-data-impex.asd 2006-02-17 20:46:26 UTC (rev 1837)
+++ branches/xml-class-rework/bknr/src/bknr-data-impex.asd 2006-02-17 20:52:07 UTC (rev 1838)
@@ -1,3 +1,4 @@
+
(in-package :cl-user)
(defpackage :bknr-data-impex.system
Modified: branches/xml-class-rework/bknr/src/data/package.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/data/package.lisp 2006-02-17 20:46:26 UTC (rev 1837)
+++ branches/xml-class-rework/bknr/src/data/package.lisp 2006-02-17 20:52:07 UTC (rev 1838)
@@ -42,6 +42,7 @@
#:persistent-xml-class
#:persistent-xml-class-importer
#:define-persistent-class
+ #:define-persistent-xml-class
#:defpersistent-class
#:store-object
Modified: branches/xml-class-rework/bknr/src/data/xml-object.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/data/xml-object.lisp 2006-02-17 20:46:26 UTC (rev 1837)
+++ branches/xml-class-rework/bknr/src/data/xml-object.lisp 2006-02-17 20:52:07 UTC (rev 1838)
@@ -39,4 +39,3 @@
(export '(persistent-xml-class))
-
Modified: branches/xml-class-rework/bknr/src/web/menu.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/web/menu.lisp 2006-02-17 20:46:26 UTC (rev 1837)
+++ branches/xml-class-rework/bknr/src/web/menu.lisp 2006-02-17 20:52:07 UTC (rev 1838)
@@ -1,13 +1,13 @@
(in-package :bknr.site-menu)
-(defparameter *menu-dtd* (cxml:parse-dtd-file (merge-pathnames #p"menu.dtd" *load-truename*)))
+(defparameter *menu-dtd* (ext:unix-namestring (merge-pathnames #p"menu.dtd" *load-truename*)))
(defclass menu-defs ()
((menus :initarg :menus
:element "menu"
:reader menu-defs-menus))
(:metaclass xml-class)
- (:dtd *menu-dtd*)
+ (:dtd-name *menu-dtd*)
(:element "menus"))
(defclass menu ()
@@ -18,7 +18,7 @@
:element "item"
:reader menu-items))
(:metaclass xml-class)
- (:dtd *menu-dtd*)
+ (:dtd-name *menu-dtd*)
(:element "menu"))
(defclass item ()
@@ -39,7 +39,7 @@
:reader item-hover-image))
(:default-initargs :inactive-image nil :active-image nil :hover-image nil)
(:metaclass xml-class)
- (:dtd *menu-dtd*)
+ (:dtd-name *menu-dtd*)
(:element "item"))
(defparameter *menu-def-classes* (mapcar #'find-class '(menu-defs menu item)))
Modified: branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp 2006-02-17 20:46:26 UTC (rev 1837)
+++ branches/xml-class-rework/bknr/src/xml-impex/tutorial.lisp 2006-02-17 20:52:07 UTC (rev 1838)
@@ -31,9 +31,9 @@
;;;# Obtaining and loading BKNR XML import/export
;;;
;;; You can obtain the current CVS sources of BKNR by following the
-;;; instructions at `http://bknr.net/blog/bknr-devel'. Add the `src'
-;;; directory of BKNR to your `asdf:*central-registry*', and load the
-;;; indices module by evaluating the following form:
+;;; instructions at `http://bknr.net/'. Add the `src' directory of
+;;; BKNR to your `asdf:*central-registry*', and load the indices
+;;; module by evaluating the following form:
(asdf:oos 'asdf:load-op :bknr-impex)
@@ -90,8 +90,7 @@
;;; class, and by specifying the XML element corresponding to the
;;; class. We also annotate the slot definitions.
-(defvar *tutorial-dtd*
- (cxml:parse-dtd-file "xml-impex/tutorial.dtd"))
+(defvar *tutorial-dtd* "xml-impex/tutorial.dtd")
(defclass book ()
((author :initarg :author :reader book-author
@@ -103,7 +102,7 @@
(title :initarg :title :reader book-title
:element "title"))
(:metaclass xml-class)
- (:dtd *tutorial-dtd*)
+ (:dtd-name *tutorial-dtd*)
(:element "book"))
;;; We can now read the XML file containing the book definitions. As
@@ -161,7 +160,7 @@
(title :initarg :title :reader book-title
:element "title"))
(:metaclass xml-class)
- (:dtd *tutorial-dtd*)
+ (:dtd-name *tutorial-dtd*)
(:element "book"))
;;; We can now import our XML file and the indices will automatically
@@ -243,8 +242,7 @@
;;; We can then write the following class definitions:
-(defvar *test-dtd*
- (cxml:parse-dtd-file #p"xml-impex/tutorial2.dtd"))
+(defvar *test-dtd* "xml-impex/tutorial2.dtd")
(defclass test-object ()
((id :initarg :id :attribute "id"
@@ -252,7 +250,7 @@
:index-type unique-index :index-reader object-with-id
:index-values all-objects))
(:metaclass xml-class)
- (:dtd *test-dtd*)
+ (:dtd-name *test-dtd*)
(:element nil))
(defmethod print-object ((object test-object) stream)
@@ -264,7 +262,7 @@
:index-reader test-with-id
:index-values all-tests))
(:metaclass xml-class)
- (:dtd *test-dtd*)
+ (:dtd-name *test-dtd*)
(:element "test"))
(defclass test2 (test-object)
@@ -272,7 +270,7 @@
:index-reader test2-with-id
:index-values all-test2s))
(:metaclass xml-class)
- (:dtd *test-dtd*)
+ (:dtd-name *test-dtd*)
(:element "test2"))
(defclass test3 (test-object)
@@ -280,7 +278,7 @@
:index-reader test3-with-id
:index-values all-test3s))
(:metaclass xml-class)
- (:dtd *test-dtd*)
+ (:dtd-name *test-dtd*)
(:element "test3"))
;;; When we parse a sample file, we get the following results:
@@ -331,8 +329,7 @@
;;; we can write the following class definition:
-(defvar *adult-dtd*
- (cxml:parse-dtd-file "xml-impex/tutorial3.dtd"))
+(defvar *adult-dtd* "xml-impex/tutorial3.dtd")
(defclass adult ()
((name :initarg :name :attribute "name"
@@ -340,7 +337,7 @@
(children :initarg :children :element "child"
:reader adult-children))
(:metaclass xml-class)
- (:dtd *adult-dtd*)
+ (:dtd-name *adult-dtd*)
(:element "adult"))
(defmethod print-object ((adult adult) stream)
@@ -351,7 +348,7 @@
((name :initarg :name :attribute "name"
:reader child-name))
(:metaclass xml-class)
- (:dtd *adult-dtd*)
+ (:dtd-name *adult-dtd*)
(:element "child"))
(defmethod print-object ((child child) stream)
@@ -403,7 +400,7 @@
(parent :initarg :parent :parent t
:reader child-parent))
(:metaclass xml-class)
- (:dtd *adult-dtd*)
+ (:dtd-name *adult-dtd*)
(:element "child"))
(setf *adults*
@@ -429,8 +426,7 @@
book-id CDATA #REQUIRED
reviewer CDATA #REQUIRED>
-(defvar *resume-dtd*
- (cxml:parse-dtd-file "xml-impex/tutorial4.dtd"))
+(defvar *resume-dtd* "xml-impex/tutorial4.dtd")
(defclass book-resume ()
((id :initarg :id :attribute "id"
@@ -444,7 +440,7 @@
(review :initarg :review :body t
:reader book-resume-review))
(:metaclass xml-class)
- (:dtd *resume-dtd*)
+ (:dtd-name *resume-dtd*)
(:element "book-resume"))
;;; Parsing the following file gives the results:
@@ -498,8 +494,7 @@
;;; We can write the following class definitions:
-(defparameter *book2-dtd*
- (cxml:parse-dtd-file "xml-impex/tutorial5.dtd"))
+(defparameter *book2-dtd* "xml-impex/tutorial5.dtd")
(defclass author ()
((id :initarg :id :reader author-id
@@ -509,7 +504,7 @@
(name :initarg :name :reader author-name
:element "name"))
(:metaclass xml-class)
- (:dtd *book2-dtd*)
+ (:dtd-name *book2-dtd*)
(:element "author"))
(defmethod print-object ((author author) stream)
@@ -528,7 +523,7 @@
(title :initarg :title :reader book-title
:element "title"))
(:metaclass xml-class)
- (:dtd *book2-dtd*)
+ (:dtd-name *book2-dtd*)
(:element "book"))
;;; We can then read the following XML file:
Modified: branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp 2006-02-17 20:46:26 UTC (rev 1837)
+++ branches/xml-class-rework/bknr/src/xml-impex/xml-class.lisp 2006-02-17 20:52:07 UTC (rev 1838)
@@ -1,8 +1,7 @@
(in-package :bknr.impex)
(defclass xml-class (indexed-class)
- ((dtd :initarg :dtd :initform nil :accessor xml-class-dtd)
- (element :initarg :element :initform nil :accessor xml-class-element)
+ ((element :initarg :element :initform nil :accessor xml-class-element)
(unique-id-slot :initarg :unique-id-slot :initform nil
:documentation "if set to a slot name, this
signals that the slot can be used as a unique id to refer to an
@@ -67,65 +66,15 @@
(defmethod print-object ((slot xml-effective-slot-definition) stream)
(print-unreadable-object (slot stream :type t :identity t)
- (format stream "~A (~A ~S)" (slot-definition-name slot)
- (with-slots (attribute element body parent) slot
+ (with-slots (attribute element body parent) slot
+ (format stream "~A (~A~@[~S~])" (slot-definition-name slot)
(cond (attribute "ATTRIBUTE")
(element "ELEMENT")
(body "BODY")
(parent "PARENT")
- (t "UNKNOWN")))
- (with-slots (attribute element body) slot
- (cond ((and attribute (typep attribute 'cxml::attdef))
- (cxml::rod-string (cxml::attdef-name attribute)))
- (attribute attribute)
- ((and element (typep element 'cxml::elmdef))
- (cxml::rod-string (cxml::elmdef-name element)))
- (element element)
- (t ""))))))
+ (t "UNKNOWN"))
+ (or attribute element)))))
-(defun get-dtd-elmdef (dtd elmdef)
- (typecase elmdef
- (string (unless dtd
- (error "Can not find elmdef ~a in dtd ~A." elmdef dtd))
- (cxml::find-element (cxml::string-rod elmdef) dtd))
- (cxml::elmdef elmdef)
- (t (let ((elmdef (eval elmdef)))
- (unless (typep elmdef 'cxml::elmdef)
- (error "Elmdef ~A is not a CXML elmdef." elmdef))
- elmdef))))
-
-(defun get-dtd (dtd)
- (cond ((or (stringp dtd)
- (pathnamep dtd))
- (cxml:parse-dtd-file dtd))
- ((typep dtd 'cxml::dtd) dtd)
- (t (let ((dtd (eval dtd)))
- (unless (typep dtd 'cxml::dtd)
- (error "DTD ~A is not a CXML dtd." dtd))
- dtd))))
-
-(defun get-elmdef-attribute (elmdef attribute)
- (typecase attribute
- (string (unless elmdef
- (error "Can not find attribute ~a in elmdef ~a." attribute elmdef))
- (cxml::find-attribute elmdef (cxml::string-rod attribute)))
- (cxml::attdef attribute)
- (t (let ((attribute (eval attribute)))
- (unless (typep attribute 'cxml::attdef)
- (error "Attribute ~A is not a CXML attdef." attribute))
- attribute))))
-
-(defmethod initialize-elmdef ((class xml-class) dtd elm)
- (let* ((dtd (get-dtd dtd))
- elmdef)
- (when elm
- (setf elmdef (get-dtd-elmdef dtd elm))
- (unless elmdef
- (error "Could not find an element definition for class ~A, elmdef ~A."
- (class-name class) elm)))
- (setf (xml-class-dtd class) dtd
- (xml-class-element class) elmdef)))
-
(defmethod xml-class-attribute-slots ((class xml-class))
(remove-if #'(lambda (slot)
(or (not (typep slot 'xml-effective-slot-definition))
@@ -148,12 +97,12 @@
(defmethod xml-class-find-attribute-slot ((class xml-class) attribute)
(find attribute (xml-class-attribute-slots class)
:test #'string-equal
- :key #'(lambda (slot) (cxml::rod-string (cxml::attdef-name (slot-value slot 'attribute))))))
+ :key #'(lambda (slot) (slot-value slot 'attribute))))
(defmethod xml-class-find-element-slot ((class xml-class) element)
(find element (xml-class-element-slots class)
:test #'string-equal
- :key #'(lambda (slot) (cxml::rod-string (cxml::elmdef-name (slot-value slot 'element))))))
+ :key #'(lambda (slot) (slot-value slot 'element))))
(defmethod xml-class-parent-slot ((class xml-class))
(let ((parent-slots
@@ -165,84 +114,12 @@
(error "Class ~A has more than one parent slot: ~A." class parent-slots))
(first parent-slots)))
-(defmethod elmdef-children ((elmdef cxml::elmdef))
- (let (result)
- (labels ((elmdef-children-rec (content containment)
- (cond ((and (listp content)
- (member (first content) '(cxml::and cxml::or)))
- (dolist (child (cdr content))
- (elmdef-children-rec child containment)))
- ((and (listp content)
- (eql (first content) 'cxml::+))
- (dolist (child (cdr content))
- (elmdef-children-rec child :+)))
- ((and (listp content)
- (eql (first content) 'cxml::*))
- (dolist (child (cdr content))
- (elmdef-children-rec child :*)))
- ((and (listp content)
- (eql (first content) 'cxml::?))
- (dolist (child (cdr content))
- (elmdef-children-rec child :optional)))
- ((listp content)
- (error "Unknown content form ~S (missing element declaration for ~S in DTD?)." content (cxml::elmdef-name elmdef)))
- ((eql content :pcdata))
- ((eql content :empty))
- (t (push (list content containment) result)))))
- (elmdef-children-rec (cxml::elmdef-content elmdef) :single)
- (nreverse result))))
-
-;;; called multiple times
-(defmethod compute-slots :around ((class xml-class))
- #+nil
- (format t "around dtd ~A~%" (xml-class-dtd class))
- (when (and (not (typep (xml-class-dtd class) 'cxml::dtd))
- (xml-class-dtd class))
- (initialize-elmdef class (first (xml-class-dtd class))
- (first (xml-class-element class))))
- (call-next-method))
-
-(defmethod xml-class-finalize ((class xml-class))
- (unless (class-finalized-p class)
- (finalize-inheritance class))
-
- (let ((slots (class-slots class))
- (elmdef (xml-class-element class)))
- (unless elmdef
- (return-from xml-class-finalize))
-
- #+nil
- (format t "~S slots attributes ~S~%" slots (xml-class-attribute-slots class))
- ;;; check attributes
- (dolist (attr (cxml::elmdef-attributes elmdef))
- (let ((attr-name (cxml::rod-string (cxml::attdef-name attr))))
- (when (eql (cxml::attdef-default attr) :required)
- (let ((slot (xml-class-find-attribute-slot class attr-name)))
- (when (not slot)
- (warn "Could not find slot for required attribute ~A." attr-name))))))
- ;;; check elements
- (dolist (child (elmdef-children elmdef))
- (let* ((child-name (cxml::rod-string (first child)))
- (child-containment (second child))
- (slot (xml-class-find-element-slot class child-name)))
- (if slot
- (with-slots (containment required-p) slot
- (if containment
- (when (not (eql containment child-containment))
- (error "Slot containment ~A is not the same as the child containment ~A."
- containment child-containment))
- (setf containment child-containment))
- (when (member child-containment '(:single :+))
- (setf required-p t)))
- (when (member child-containment '(:single :+))
- (warn "Could not find a slot for the child element ~A with containment ~A."
- child-name child-containment)))))
- slots))
-
-(defmethod initialize-instance :after ((class xml-class) &key &allow-other-keys)
+(defmethod initialize-instance :after ((class xml-class) &key element &allow-other-keys)
+ (setf (xml-class-element class) (or (first element) (string-downcase (class-name class))))
(xml-class-finalize class))
-(defmethod reinitialize-instance :after ((class xml-class) &key &allow-other-keys)
+(defmethod reinitialize-instance :after ((class xml-class) &key element &allow-other-keys)
+ (setf (xml-class-element class) (or (first element) (string-downcase (class-name class))))
(xml-class-finalize class))
(defmethod direct-slot-definition-class ((class xml-class) &key parent attribute element body &allow-other-keys)
@@ -264,22 +141,20 @@
(let ((normal-slot (call-next-method)))
(when (and xml-direct
- (typep normal-slot 'xml-effective-slot-definition)
- (xml-class-element class))
+ (typep normal-slot 'xml-effective-slot-definition))
(with-slots (attribute element body parent) xml-direct
- (let ((dtd (xml-class-dtd class)))
- (unless (or element attribute body parent)
- (error "Could not find element or attribute for slot ~A." name))
- (when (> (length (remove nil (list parent element attribute body))) 1)
- (error "Only one of ELEMENT, ATTRIBUTE, PARENT or BODY is possible for a slot definition."))
+ (when (> (length (remove nil (list parent element attribute body))) 1)
+ (error "Only one of ELEMENT, ATTRIBUTE, PARENT or BODY is possible for a slot definition."))
+ (unless (or body parent)
+ (unless (or element attribute)
+ (setf element (string-downcase name)))
(when element
- (setf element (get-dtd-elmdef dtd element)))
+ (setf element (if (eq t element) (string-downcase name) element)))
(when attribute
- (setf attribute (get-elmdef-attribute (xml-class-element class)
- attribute)))
- (unless (or element attribute body parent)
+ (setf attribute (if (eq t attribute) (string-downcase name) attribute)))
+ (unless (or element attribute)
(error "Could not find element or attribute for slot ~A." name))))
-
+
(dolist (slot '(parser serializer body id-to-object object-to-id
parent attribute element))
(setf (slot-value normal-slot slot)
@@ -290,22 +165,9 @@
(when value
(setf (slot-value normal-slot slot)
(eval value)))))
-
- ;;; XXX check emptyness of element
- (with-slots (attribute element containment required-p) normal-slot
- (when attribute
- (when (eql (cxml::attdef-default attribute) :required)
- (setf required-p t))))
-
+
normal-slot)))
-(defmethod xml-class-reload-dtd ((class xml-class) dtd &optional element)
- (let ((element (if element
- element
- (cxml::rod-string (cxml::elmdef-name (xml-class-element class))))))
- (initialize-elmdef class dtd element)
- class))
-
(defmethod xml-object-check-validity (object)
(let ((class (class-of object)))
(unless (typep class 'xml-class)
Modified: branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp
===================================================================
--- branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp 2006-02-17 20:46:26 UTC (rev 1837)
+++ branches/xml-class-rework/bknr/src/xml-impex/xml-export.lisp 2006-02-17 20:52:07 UTC (rev 1838)
@@ -33,15 +33,15 @@
(let* ((attr-slots (xml-class-attribute-slots class))
(elt-slots (xml-class-element-slots class))
(body-slot (xml-class-body-slot class))
- (qname (cxml::elmdef-name (xml-class-element class)))
+ (qname (cxml::string-rod (xml-class-element class)))
;; attributes
(attributes (loop for slot in attr-slots
for name = (slot-definition-name slot)
- for attdef = (xml-effective-slot-definition-attribute slot)
+ for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot))
when (and (slot-boundp object name)
(slot-value object name))
collect (sax:make-attribute
- :qname (cxml::attdef-name attdef)
+ :qname attdef
:value
(funcall string-rod-fn
(slot-serialize-value slot (slot-value object name)))))))
More information about the Bknr-cvs
mailing list