Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'master' of http://github.com/hanshuebner/bknr-datastore

  • Loading branch information...
commit f394b0137067ebe742059dc909970db2045a7ddc 2 parents 81ae57f + 9086b85
@madnificent madnificent authored
View
85 src/xml-impex/xml-class.lisp
@@ -141,10 +141,93 @@ through the object-id-slot (either an element or an attribute)")
(xml-class-element class) (or (first element) (string-downcase (class-name class))))
(xml-class-finalize class))
+(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))
+ (warn "DTD ~A is not a CXML dtd." dtd))
+ dtd))))
+
+(defun get-dtd-elmdef (dtd elmdef)
+ "Finds an element definition in a DTD. Returns a cxml: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))))
+
+(defmethod elmdef-children ((elmdef cxml::elmdef))
+ "Analyses the content field of a given elmdef and returns a list of element/containment
+pairs, representing the childs and their containment definition"
+ (let (result)
+ (labels ((elmdef-children-rec (content containment)
+ (format t "~S content containmnt ~S~%" 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))))
+
(defmethod xml-class-finalize ((class xml-class))
(unless (class-finalized-p class)
(finalize-inheritance class))
-
+
+ (let* ((slots (class-slots class))
+ (dtd (get-dtd (xml-class-dtd-name class)))
+ (elmdef (when dtd (get-dtd-elmdef dtd (xml-class-element class)))))
+
+ (unless elmdef
+ (return-from xml-class-finalize))
+ ;;; 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))))))
(class-slots class))
(defmethod direct-slot-definition-class ((class xml-class) &key parent attribute element body &allow-other-keys)
View
10 src/xml-impex/xml-export.lisp
@@ -14,9 +14,13 @@
(cxml::*current-element* nil)
(sink (cxml:make-character-stream-sink ,output :indentation ,indentation :canonical ,canonical)))
(with-xml-output sink
- (build-xml ,object :name ,name))
- ))
-
+ (build-xml ,object :name ,name))))
+
+(defmacro write-to-xml-string (object &key name (indentation 3) (canonical nil))
+ `(let ((output-string (make-string-output-stream)))
+ (get-output-stream-string
+ (write-to-xml ,object :name ,name :output output-string :indentation ,indentation :canonical ,canonical))))
+
(defmacro with-xml-export* ((&key output indentation canonical) &body body)
`(let ((*objects-written* (make-hash-table :test #'equal))
(cxml::*current-element* nil)
View
2  src/xml-impex/xml-import.lisp
@@ -82,8 +82,6 @@
;; parse the value if necessary
(setf value (slot-parse-value slot value))
(let ((containment (xml-effective-slot-definition-containment slot)))
- ;; FIXME: the documentation omits the need to specify the containment slot
- ;; Either make it a requirement of initialise it from the dtd (?)
(if (member containment '(:* :+))
;; if it has a plural containment, push the
;; created instance into the initargs hash

0 comments on commit f394b01

Please sign in to comment.
Something went wrong with that request. Please try again.