[bknr-cvs] r1840 - in trunk: bknr/src/data bknr/src/web bknr/src/xml-impex projects projects/bknr-website/templates projects/lisp-ecoop05/src
bknr at bknr.net
bknr at bknr.net
Fri Feb 17 21:05:52 UTC 2006
Author: hhubner
Date: 2006-02-17 15:05:51 -0600 (Fri, 17 Feb 2006)
New Revision: 1840
Added:
trunk/projects/lisp-ecoop05/
Removed:
trunk/bknr/src/xml-impex/xml-update.lisp
trunk/projects/lisp-ecoop/
Modified:
trunk/bknr/src/data/object.lisp
trunk/bknr/src/web/handlers.lisp
trunk/bknr/src/xml-impex/xml-class.lisp
trunk/bknr/src/xml-impex/xml-import.lisp
trunk/projects/bknr-website/templates/generate-html.xsl
trunk/projects/lisp-ecoop05/src/alu-logo.jpg
trunk/projects/lisp-ecoop05/src/bknr-logo.png
Log:
Back out changes in trunk back to 1827 in the hopes to have trunk in a
useable state. I'm moving my current project work to the branch
xml-class-rework as some of the changes will introduce incompatibilties
to the existing and documented xml-class API (among others).
Modified: trunk/bknr/src/data/object.lisp
===================================================================
--- trunk/bknr/src/data/object.lisp 2006-02-17 20:55:40 UTC (rev 1839)
+++ trunk/bknr/src/data/object.lisp 2006-02-17 21:05:51 UTC (rev 1840)
@@ -204,26 +204,20 @@
(relaxed-object-reference-slot-p slot))))
(defmacro define-persistent-class (class (&rest superclasses) slots &rest class-options)
- (let ((superclasses (or superclasses '(store-object)))
- (metaclass (cadr (assoc :metaclass class-options))))
- (when (and metaclass
- (not (validate-superclass (find-class metaclass)
- (find-class 'persistent-class))))
- (error "Can not define a persistent class with metaclass ~A." metaclass))
+ (let ((superclasses (or superclasses '(store-object))))
+ (when (member :metaclass class-options :key #'car)
+ (error "Can not define a persistent class with a metaclass."))
`(define-bknr-class ,class ,superclasses ,slots
- ,@(unless metaclass '(:metaclass persistent-class))
+ (:metaclass persistent-class)
, at class-options)))
(defmacro defpersistent-class (class (&rest superclasses) slots &rest class-options)
- (let ((superclasses (or superclasses '(store-object)))
- (metaclass (cadr (assoc :metaclass class-options))))
- (when (and metaclass
- (not (validate-superclass (find-class metaclass)
- (find-class 'persistent-class))))
- (error "Can not define a persistent class with metaclass ~A." metaclass))
+ (let ((superclasses (or superclasses '(store-object))))
+ (when (member :metaclass class-options :key #'car)
+ (error "Can not define a persistent class with a metaclass."))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,class ,superclasses ,slots
- ,@(unless metaclass '(:metaclass persistent-class))
+ (:metaclass persistent-class)
, at class-options))))
#+nil
Modified: trunk/bknr/src/web/handlers.lisp
===================================================================
--- trunk/bknr/src/web/handlers.lisp 2006-02-17 20:55:40 UTC (rev 1839)
+++ trunk/bknr/src/web/handlers.lisp 2006-02-17 21:05:51 UTC (rev 1840)
@@ -446,10 +446,9 @@
:string-rod-fn #'cxml::utf8-string-to-rod))
(defmethod handle-object ((handler xml-object-list-handler) object req)
- (let ((element-name (xml-object-list-handler-toplevel-element-name handler)))
- (cxml:with-element element-name
- (dolist (object (object-list-handler-get-objects handler object req))
- (object-list-handler-show-object-xml handler object req)))))
+ (cxml:with-element (xml-object-list-handler-toplevel-element-name handler)
+ (dolist (object (object-list-handler-get-objects handler object req))
+ (object-list-handler-show-object-xml handler object req))))
(defclass blob-handler (object-handler)
())
Modified: trunk/bknr/src/xml-impex/xml-class.lisp
===================================================================
--- trunk/bknr/src/xml-impex/xml-class.lisp 2006-02-17 20:55:40 UTC (rev 1839)
+++ trunk/bknr/src/xml-impex/xml-class.lisp 2006-02-17 21:05:51 UTC (rev 1840)
@@ -2,22 +2,8 @@
(defclass xml-class (indexed-class)
((dtd :initarg :dtd :initform nil :accessor xml-class-dtd)
- (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
-instance of the object in a n XML update operation")
- (unique-id-reader :initarg :unique-id-reader :initform nil
- :documentation "if set to a function, this
-signals that the function can be used as a unique index-reader when
-used in XML update operations.")))
+ (element :initarg :element :initform nil :accessor xml-class-element)))
-(defmethod xml-class-unique-id-slot ((class xml-class))
- (first (slot-value class 'unique-id-slot)))
-
-(defmethod xml-class-unique-id-reader ((class xml-class))
- (eval (first (slot-value class 'unique-id-reader))))
-
(defmethod validate-superclass ((sub xml-class) (super indexed-class))
t)
@@ -45,7 +31,7 @@
(object-to-id :initarg :object-to-id
:initform nil
:documentation "Function used to get the ID of the object stored in the slot.")
-
+
(parent :initarg :parent
:initform nil
:documentation "Slot is a pointer to the parent object.")))
@@ -115,14 +101,11 @@
(error "Attribute ~A is not a CXML attdef." attribute))
attribute))))
-(defmethod initialize-elmdef ((class xml-class) dtd elm)
+(defmethod initialize-elmdef ((class xml-class) dtd elmdef)
(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)))
+ (elmdef (when elmdef (get-dtd-elmdef dtd elmdef))))
+ (unless elmdef
+ (error "Could not find an element definition for ~A." class))
(setf (xml-class-dtd class) dtd
(xml-class-element class) elmdef)))
Modified: trunk/bknr/src/xml-impex/xml-import.lisp
===================================================================
--- trunk/bknr/src/xml-impex/xml-import.lisp 2006-02-17 20:55:40 UTC (rev 1839)
+++ trunk/bknr/src/xml-impex/xml-import.lisp 2006-02-17 21:05:51 UTC (rev 1840)
@@ -6,6 +6,12 @@
(root-elt :initform nil :accessor importer-root-elt)
(parent-elts :initform nil :accessor importer-parent-elts)))
+(defclass xml-class-instance ()
+ ((initforms :initform nil :initarg :initforms :reader instance-initforms)
+ (children :initarg :children :accessor instance-children)
+ (elmdef :initarg :elmdef :accessor instance-elmdef)
+ (class :initarg :class :initform nil :accessor instance-class)))
+
(defmethod slot-parse-value ((slot xml-effective-slot-definition) value)
(with-slots (parser id-to-object) slot
(when parser
@@ -14,149 +20,49 @@
(setf value (funcall id-to-object value)))
value))
-;;; description for an object instance to be created from the xml. The
-;;; data is gathered while parsing the XML, and at the end of an
-;;; element, the corresponding object is instanciated.
+(defmethod xml-class-attribute-initforms ((class xml-class) attributes)
+ (let (results)
+ (dolist (attr attributes)
+ (let ((slot (xml-class-find-attribute-slot class (sax:attribute-qname attr))))
+ (when slot
+ (push (first (slot-definition-initargs slot)) results)
+ (push (slot-parse-value slot (sax:attribute-value attr)) results))))
+ (nreverse results)))
-(defclass xml-node ()
- ((element :initarg :element :accessor node-element)
- (children :initarg :children :initform (make-hash-table) :accessor node-children)
- (elmdef :initarg :elmdef :accessor instance-elmdef)
- (attributes :initarg :attributes :accessor node-attributes)
- (data :initarg :data :initform nil :accessor node-data)))
-
-(defmethod print-object ((node xml-node) stream)
- (print-unreadable-object (node stream :type t)
- (format stream "~a" (node-element node))))
-
-(defclass xml-class-instance (xml-node)
- ((slots :initform (make-hash-table :test #'equal) :accessor instance-slots)
- (class :initarg :class :initform nil :accessor instance-class)))
-
-(defmethod print-object ((instance xml-class-instance) stream)
- (print-unreadable-object (instance stream :type t)
- (format stream "~a" (instance-class instance))))
-
-(defgeneric importer-add-attribute (handler node attr))
-(defgeneric importer-add-characters (handler node data))
-(defgeneric importer-add-element (handler node element value))
-(defgeneric importer-finalize (handler node))
-
-(defmethod importer-add-attribute ((handler xml-class-importer)
- (class-instance xml-class-instance) attr)
- (with-slots (class slots) class-instance
- (let ((slot (xml-class-find-attribute-slot class (sax:attribute-qname attr))))
- (when slot
- (setf (gethash slot slots) (slot-parse-value slot (sax:attribute-value attr)))))))
-
-(defmethod importer-add-attribute ((handler xml-class-importer)
- (node xml-node) attr)
- nil)
-
-(defmethod importer-add-characters ((handler xml-class-importer)
- (node xml-node) characters)
- (unless (whitespace-p characters)
- (setf characters (string-trim bknr.utils::+whitespace-chars+ characters))
- (with-slots (data) node
- (setf data (if data
- (concatenate 'string data characters)
- characters)))))
-
-(defmethod importer-add-characters ((handler xml-class-importer)
- (instance xml-class-instance) characters)
- (with-slots (class elmdef slots children) instance
- (let ((slot (xml-class-body-slot class)))
- (when slot
- (setf (gethash slot slots) (slot-parse-value slot characters))))))
-
-(defmethod importer-add-element ((handler xml-class-importer)
- (node xml-node) element value)
- (with-slots (children) node
- (push value (gethash (make-keyword-from-string element) children))))
-
-(defmethod importer-add-element ((handler xml-class-importer)
- (instance xml-class-instance) element value)
- (with-slots (slots elmdef class children) instance
- (let ((slot (xml-class-find-element-slot class element)))
- (when slot
- ;; parse the value if necessary
- (setf value (slot-parse-value slot value))
- (let ((containment (xml-effective-slot-definition-containment slot)))
- (if (member containment '(:* :+))
- ;; if it has a plural containment, push the
- ;; created instance into the initargs hash
- (push value (gethash slot slots))
- ;; else set the initarg hash to the new instance
- (setf (gethash slot slots) value)))))))
-
-(defmethod importer-finalize ((handler xml-class-importer)
- (node xml-node))
- (with-slots (data children) node
- (cond
- ((and data
- (= (hash-table-count children) 0)) data)
- ((> (hash-table-count children) 0)
- (children-to-initforms (node-children node)))
- (t nil))))
-
-(defun add-parent (handler parent child)
- (let* ((class (class-of child))
- (parent-slot (when (typep class 'xml-class)
- (xml-class-parent-slot class))))
- (when parent-slot
- (set-slot-value handler child (slot-definition-name parent-slot) parent))))
-
-(defun slots-to-initforms (slots)
- (let (initforms)
- (loop for slot being the hash-keys of slots using (hash-value value)
- when (listp value)
- do (push (reverse value) initforms)
- else do (push value initforms)
- do (push (first (slot-definition-initargs slot)) initforms))
- initforms))
-
-(defmethod importer-finalize ((handler xml-class-importer)
- (instance xml-class-instance))
- (with-slots (class elmdef children slots) instance
- (let* ((initforms (slots-to-initforms slots))
- (object (apply #'create-instance handler (class-name class) initforms)))
-
- (loop for objs being the hash-values of slots
- when (listp objs)
- do (dolist (child objs)
- (add-parent handler object child))
- else do (add-parent handler object objs))
-
- object)))
-
(defmethod sax:start-document ((handler xml-class-importer))
(setf (importer-root-elt handler) nil))
(defmethod sax:start-element ((handler xml-class-importer) namespace-uri local-name qname attrs)
(declare (ignore namespace-uri local-name))
- (let ((class (gethash qname (importer-class-hash handler)))
- (element (cxml::string-rod qname))
- instance)
+ (let ((class (gethash qname (importer-class-hash handler))))
(if class
- (setf instance
- (make-instance 'xml-class-instance
- :element element
- :elmdef (xml-class-element class)
- :class class))
- (setf instance
- (make-instance 'xml-node
- :element element
- :elmdef (cxml::find-element element (importer-dtd handler)))))
+ (let ((instance (make-instance 'xml-class-instance
+ :children (make-hash-table)
+ :initforms (xml-class-attribute-initforms class attrs)
+ :elmdef (xml-class-element class)
+ :class class)))
+ (push instance (importer-parent-elts handler)))
+ (let ((instance (make-instance 'xml-class-instance
+ :children (make-hash-table)
+ :initforms nil
+ :elmdef (cxml::find-element (cxml::string-rod qname)
+ (importer-dtd handler))
+ :class nil)))
+ (push instance (importer-parent-elts handler))))))
- (dolist (attr attrs)
- (importer-add-attribute handler instance attr))
-
- (push instance (importer-parent-elts handler))))
-
(defmethod sax:characters ((handler xml-class-importer) data)
(unless (importer-parent-elts handler)
(error "Can not parse SAX:CHARACTERS without a parent element."))
- (importer-add-characters handler (first (importer-parent-elts handler)) data))
+ (let ((instance (first (importer-parent-elts handler))))
+ (with-slots (class elmdef initforms children) instance
+ (if class
+ (let ((slot (xml-class-body-slot class)))
+ (when slot
+ (push (funcall (xml-effective-slot-definition-parser slot) data) initforms)
+ (push (first (slot-definition-initargs slot)) initforms)))
+ (unless (whitespace-p data)
+ (setf data (string-trim bknr.utils::+whitespace-chars+ data))
+ (setf initforms (if initforms (concatenate 'string initforms data) data)))))))
(defmethod create-instance ((handler xml-class-importer) class-name &rest initargs)
(apply #'make-instance class-name initargs))
@@ -166,15 +72,43 @@
(defmethod sax:end-element ((handler xml-class-importer) namespace-uri local-name qname)
(declare (ignore namespace-uri local-name))
+ (let ((instance (pop (importer-parent-elts handler))))
+ (with-slots (class initforms elmdef children) instance
+ (loop for key being the hash-keys of children using (hash-value value)
+ when (listp value)
+ do (push (reverse value) initforms)
+ else do (push value initforms)
+ do (push key initforms))
+
+ (let ((instance (if class
+ (apply #'create-instance handler (class-name class) initforms)
+ initforms)))
- (let* ((instance (pop (importer-parent-elts handler)))
- (final (importer-finalize handler instance))
- (parent (first (importer-parent-elts handler))))
+ (when class
+ (loop for objs being the hash-values of children
+ when (listp objs)
+ do (loop for child in objs
+ for child-class = (class-of child)
+ for parent-slot = (when (typep child-class 'xml-class)
+ (xml-class-parent-slot (class-of child)))
+ when parent-slot
+ do (set-slot-value handler child (slot-definition-name parent-slot) instance))))
- (when parent
- (importer-add-element handler parent qname final))
-
- (setf (importer-root-elt handler) final)))
+ (let ((parent (first (importer-parent-elts handler))))
+ (when parent
+ (if (instance-class parent)
+ (let ((slot (xml-class-find-element-slot (instance-class parent) qname)))
+ (when slot
+ (setf instance (slot-parse-value slot instance))
+ (let ((containment (xml-effective-slot-definition-containment slot)))
+ (if (member containment '(:* :+))
+ (push instance (gethash (first (slot-definition-initargs slot))
+ (instance-children parent)))
+ (setf (gethash (first (slot-definition-initargs slot))
+ (instance-children parent)) instance)))))
+ (push instance (gethash (make-keyword-from-string qname)
+ (instance-children parent))))))
+ (setf (importer-root-elt handler) instance)))))
(defun parse-xml-file (xml-file classes &key (recoder #'cxml::rod-string)
(importer-class 'xml-class-importer))
Deleted: trunk/bknr/src/xml-impex/xml-update.lisp
===================================================================
--- trunk/bknr/src/xml-impex/xml-update.lisp 2006-02-17 20:55:40 UTC (rev 1839)
+++ trunk/bknr/src/xml-impex/xml-update.lisp 2006-02-17 21:05:51 UTC (rev 1840)
@@ -1,39 +0,0 @@
-(in-package :bknr.impex)
-
-;;; sax parser for xml impex updater, reads updates to objects from an xml file
-
-(defclass xml-class-updater (xml-class-importer)
- ())
-
-(defun class-find-slot (class slot-name)
- (find-if #'(lambda (slot)
- (equal (slot-definition-name slot) slot-name))
- (mop:class-slots class)))
-
-(defmethod importer-finalize ((handler xml-class-updater)
- (instance xml-class-instance))
- (with-slots (class slots) instance
- (if (and (xml-class-unique-id-slot class)
- (xml-class-unique-id-reader class))
- (let* ((id-slot (class-find-slot class (xml-class-unique-id-slot class)))
- (id-value (gethash id-slot slots))
- (obj (when id-value (funcall (xml-class-unique-id-reader class) id-value))))
- (if (and obj id-value)
- (progn
- (loop for slot being the hash-keys of slots using (hash-value value)
- when (not (equal (slot-definition-name slot) (xml-class-unique-id-slot class)))
- do
- (format t "updating slot ~A with ~S~%" (slot-definition-name slot)
- value)
- (setf (slot-value obj (slot-definition-name slot))
- value))
- obj)
- (progn
- (warn "no id-value or object found, creating new~%")
- (call-next-method))))
-
- (call-next-method))))
-
-(defun parse-xml-update-file (xml-file classes &key (recoder #'cxml::rod-string)
- (importer-class 'xml-class-updater))
- (parse-xml-file xml-file classes :recoder recoder :importer-class importer-class))
Modified: trunk/projects/bknr-website/templates/generate-html.xsl
===================================================================
--- trunk/projects/bknr-website/templates/generate-html.xsl 2006-02-17 20:55:40 UTC (rev 1839)
+++ trunk/projects/bknr-website/templates/generate-html.xsl 2006-02-17 21:05:51 UTC (rev 1840)
@@ -1,4 +1,4 @@
<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0">
<xsl:output mode="text" omit-xml-declaration="yes" />
<xsl:template match="item">xsltproc --stringparam mode html -o ../html/<xsl:value-of select="@url"/>.html <xsl:value-of select="@url"/>.xml</xsl:template>
-</xsl:stylesheet>
+</xsl:stylesheet>
\ No newline at end of file
Copied: trunk/projects/lisp-ecoop05 (from rev 1827, trunk/projects/lisp-ecoop05)
More information about the Bknr-cvs
mailing list