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