[isidorus-cvs] r301 - in branches/new-datamodel/src: unit_tests xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Jun 17 16:10:38 UTC 2010
Author: lgiessmann
Date: Thu Jun 17 12:10:37 2010
New Revision: 301
Log:
new-datamodel: adapted the xtm 1.0 exporter to the new datamodel; fixed a bug in list-extern-associations
Modified:
branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp
branches/new-datamodel/src/xml/xtm/exporter.lisp
branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp
branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp
Modified: branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp Thu Jun 17 12:10:37 2010
@@ -51,7 +51,8 @@
:test-exporter-xtm2.0-versions-1 :test-exporter-xtm2.0-versions-2
:test-exporter-xtm2.0-versions-3 :test-fragments-versions
:test-exporter-xtm1.0-versions-1 :test-exporter-xtm1.0-versions-2
- :test-exporter-xtm1.0-versions-3 :test-fragments-xtm1.0-versions))
+ :test-exporter-xtm1.0-versions-3 :test-fragments-xtm1.0-versions
+ :exporter-tests))
(in-package :exporter-test)
(def-suite exporter-tests)
@@ -69,8 +70,8 @@
(error () )) ;do nothing
(handler-case (delete-file *out-xtm1.0-file*)
(error () )) ;do nothing
- (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm")
- (elephant:open-store (get-store-spec "data_base")))
+ (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm"))
+ ;(elephant:open-store (get-store-spec "data_base")))
(def-fixture refill-test-db ()
@@ -551,52 +552,82 @@
(test test-std-topics
(with-fixture refill-test-db ()
(export-xtm *out-xtm2.0-file*)
- (let ((document (dom:document-element (cxml:parse-file *out-xtm2.0-file* (cxml-dom:make-dom-builder))))
+ (let ((document (dom:document-element
+ (cxml:parse-file *out-xtm2.0-file*
+ (cxml-dom:make-dom-builder))))
(topic-counter 0))
(check-document-structure document 38 2)
(loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic")
- do (loop for subjectIdentifier across (xpath-child-elems-by-qname topic *xtm2.0-ns* "subjectIdentifier")
- do (let ((href (dom:node-value (dom:get-attribute-node subjectIdentifier "href"))))
+ do (loop for subjectIdentifier across
+ (xpath-child-elems-by-qname topic *xtm2.0-ns* "subjectIdentifier")
+ do (let ((href (dom:node-value
+ (dom:get-attribute-node subjectIdentifier "href"))))
(cond
((string= core-topic-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-association-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-occurrence-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-class-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-class-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-superclass-subclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-superclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-subclass-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-sort-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-display-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-type-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-type-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))
((string= core-instance-psi href)
(incf topic-counter)
- (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name")))))))
+ (format t "name: ~A~%"
+ (xpath-single-child-elem-by-qname topic *xtm2.0-ns*
+ "name")))))))
(is (= topic-counter 13)))))
Modified: branches/new-datamodel/src/xml/xtm/exporter.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/exporter.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/exporter.lisp Thu Jun 17 12:10:37 2010
@@ -10,19 +10,32 @@
(in-package :exporter)
-(defun list-extern-associations ()
+(defun list-extern-associations (&key (revision *TM-REVISION*))
"gets all instances of AssociationC - which does not realize an instanceOf relationship in the db"
(let ((instance-topic
(identified-construct
- (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/instance")))
+ (elephant:get-instance-by-value 'PersistentIdC 'uri *instance-psi*)))
(type-topic
(identified-construct
- (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/type"))))
+ (elephant:get-instance-by-value 'PersistentIdC 'uri *type-psi*))))
(loop for item in (elephant:get-instances-by-class 'AssociationC)
- when (not (and (or (eq instance-topic (instance-of (first (roles item))))
- (eq instance-topic (instance-of (second (roles item)))))
- (or (eq type-topic (instance-of (first (roles item))))
- (eq type-topic (instance-of (second (roles item)))))))
+ when (and (= (length (roles item :revision revision)) 2)
+ (not (and (or (eq instance-topic
+ (instance-of (first (roles item
+ :revision revision))
+ :revision revision))
+ (eq instance-topic
+ (instance-of (second (roles item
+ :revision revision))
+ :revision revision)))
+ (or (eq type-topic
+ (instance-of (first (roles item
+ :revision revision))
+ :revision revision))
+ (eq type-topic
+ (instance-of (second (roles item
+ :revision revision))
+ :revision revision))))))
collect item)))
@@ -53,12 +66,13 @@
(map 'list
#'(lambda(top)
(d:find-item-by-revision top revision))
- (if ,tm
- (union
- (d:topics ,tm) (d:associations ,tm))
- (union
- (elephant:get-instances-by-class 'd:TopicC)
- (list-extern-associations)))))))
+ (if ,tm
+ (union
+ (d:topics ,tm) (d:associations ,tm))
+ (union
+ (elephant:get-instances-by-class 'd:TopicC)
+ (list-extern-associations :revision revision)))))))
+
(defun export-xtm (xtm-path &key
tm-id
@@ -76,9 +90,11 @@
(cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil)
(if (eq xtm-format '2.0)
(with-xtm2.0
- (export-to-elem tm #'to-elem))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem elem revision))))
(with-xtm1.0
- (export-to-elem tm #'to-elem-xtm1.0)))))))))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem elem revision)))))))))))
(defun export-xtm-to-string (&key
@@ -93,9 +109,13 @@
(cxml:with-xml-output (cxml:make-string-sink :canonical nil)
(if (eq xtm-format '2.0)
(with-xtm2.0
- (export-to-elem tm #'to-elem))
+ ;(export-to-elem tm #'to-elem))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem elem revision))))
(with-xtm1.0
- (export-to-elem tm #'to-elem-xtm1.0))))))))
+ ;(export-to-elem tm #'to-elem-xtm1.0))))))))
+ (export-to-elem tm #'(lambda(elem)
+ (to-elem elem revision))))))))))
(defun export-xtm-fragment (fragment &key (xtm-format '2.0))
Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/exporter_xtm1.0.lisp Thu Jun 17 12:10:37 2010
@@ -12,7 +12,11 @@
(:import-from :constants
*XTM2.0-NS*
*XTM1.0-NS*
- *XTM1.0-XLINK*)
+ *XTM1.0-XLINK*
+ *type-psi*
+ *instance-psi*
+ *xml-uri*
+ *xml-string*)
(:export :to-elem
:to-string
:list-extern-associations
Modified: branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/exporter_xtm2.0.lisp Thu Jun 17 12:10:37 2010
@@ -32,9 +32,11 @@
(cxml:attribute "href"
(format nil "#~a" (topic-id topic revision)))))
+
(defgeneric to-elem (instance revision)
(:documentation "converts the Topic Maps construct instance to an XTM 2.0 element"))
+
(defmethod to-elem ((psi PersistentIdC) revision)
(declare (ignorable revision))
(cxml:with-element "t:subjectIdentifier"
@@ -80,7 +82,7 @@
(if (slot-boundp characteristic 'datatype)
(datatype characteristic)
"")))
- (if (string= characteristic-type "http://www.w3.org/2001/XMLSchema#anyURI") ;-> resourceRef
+ (if (string= characteristic-type *xml-uri*) ;-> resourceRef
(cxml:with-element "t:resourceRef"
(let ((ref-topic (when (and (> (length characteristic-value) 0)
(eql (elt characteristic-value 0) #\#))
More information about the Isidorus-cvs
mailing list