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