[isidorus-cvs] r320 - in branches/new-datamodel/src: model unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Oct 6 21:30:04 UTC 2010
Author: lgiessmann
Date: Wed Oct 6 17:30:04 2010
New Revision: 320
Log:
new-datamodel: adapted the rdf-importer unit-tests to the new datamodel; adapted the rdf-importer and the rdf-importer-mapping-tools to the new datamodel; fixed a bug in elephant where all subclasses of PointerC are returned when requesting one particular subctype
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/fixtures.lisp
branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp
branches/new-datamodel/src/xml/rdf/importer.lisp
branches/new-datamodel/src/xml/rdf/map_to_tm.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Wed Oct 6 17:30:04 2010
@@ -2056,14 +2056,15 @@
(let ((possible-top-ids
(delete-if-not
#'(lambda(top-id)
- (and (string= (xtm-id top-id) xtm-id)
+ (and (typep top-id 'd:TopicIdentificationC)
+ ;fixes a bug in elephant -> all PointerCs are returned
+ (string= (xtm-id top-id) xtm-id)
(string= (uri top-id) topic-id)))
;fixes a bug in get-instances-by-value that does a
;case-insensitive comparision
(elephant:get-instances-by-value
'TopicIdentificationC
- 'uri
- topic-id))))
+ 'uri topic-id))))
(when (and possible-top-ids
(identified-construct (first possible-top-ids)
:revision revision))
@@ -2074,7 +2075,7 @@
topic-id)))
(identified-construct (first possible-top-ids)
:revision revision)
- ;no revision need not to be chaecked, since the revision
+ ;no revision need not to be checked, since the revision
;is implicitely checked by the function identified-construct
))
(when (and (> (length topic-id) 0)
@@ -2100,12 +2101,14 @@
(let ((possible-ids
(delete-if-not
#'(lambda(id)
- (string= (uri id) uri))
+ (and (typep id identifier-type-symbol)
+ (string= (uri id) uri)))
(get-instances-by-value identifier-type-symbol 'uri uri))))
(when (and possible-ids
(identified-construct (first possible-ids)
:revision revision))
(unless (= (length possible-ids) 1)
+ (format t "==> ~a~%" possible-ids)
(error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri)))
(identified-construct (first possible-ids)
:revision revision)))))
@@ -3039,12 +3042,19 @@
(declare (integer revision))
(dolist (id (get-all-identifiers-of-construct construct :revision revision))
(when (>
- (length
- (union
- (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id))
- (union
- (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id))
- (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id)))))
+ (length
+ (delete-if-not #'(lambda(identifier)
+ (or (typep identifier 'PersistentIdC)
+ (typep identifier 'SubjectLocatorC)
+ (typep identifier 'ItemIdentifierC)))
+ (union
+ (elephant:get-instances-by-value
+ 'ItemIdentifierC 'uri (uri id))
+ (union
+ (elephant:get-instances-by-value
+ 'PersistentIdC 'uri (uri id))
+ (elephant:get-instances-by-value
+ 'SubjectLocatorC 'uri (uri id))))))
1)
(error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id))))))
@@ -3829,8 +3839,10 @@
#'null
(map 'list
#'(lambda(existing-pointer)
- (when (equivalent-construct existing-pointer :uri uri
- :xtm-id xtm-id)
+ (when (and (typep existing-pointer class-symbol)
+ (equivalent-construct existing-pointer
+ :uri uri
+ :xtm-id xtm-id))
existing-pointer))
(elephant:get-instances-by-value class-symbol 'd::uri uri)))))
(if existing-pointer
Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/fixtures.lisp (original)
+++ branches/new-datamodel/src/unit_tests/fixtures.lisp Wed Oct 6 17:30:04 2010
@@ -190,7 +190,8 @@
(setf d:*current-xtm* document-id)
(rdf-importer:setup-rdf-module *poems_light.rdf* db-dir :tm-id tm-id
:document-id document-id)
- (elephant:open-store (xml-importer:get-store-spec db-dir))
+
+ ;(elephant:open-store (xml-importer:get-store-spec db-dir))
(&body)
(tear-down-test-db)))
Modified: branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp Wed Oct 6 17:30:04 2010
@@ -1054,9 +1054,11 @@
:document-id document-id)
(is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20))
(let ((first-node (get-item-by-id "http://test-tm/first-node"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(first-type (get-item-by-id "http://test-tm/first-type"
- :xtm-id document-id)))
+ :xtm-id document-id
+ :revision 0)))
(is-true first-node)
(is (= (length (d::versions first-node)) 1))
(is (= (d::start-revision (first (d::versions first-node)))
@@ -1066,11 +1068,12 @@
(is (= (length (d:player-in-roles first-node)) 1))
(is (= (length (d:player-in-roles first-type)) 1))
(let ((instance-role
- (first (d:player-in-roles first-node)))
+ (first (d:player-in-roles first-node :revision 0)))
(type-role
- (first (d:player-in-roles first-type)))
+ (first (d:player-in-roles first-type :revision 0)))
(type-assoc
- (d:parent (first (d:player-in-roles first-node)))))
+ (d:parent (first (d:player-in-roles first-node :revision 0))
+ :revision 0)))
(is (= (length (d::versions type-assoc)) 1))
(is (= (d::start-revision (first (d::versions type-assoc)))
revision-2))
@@ -1080,7 +1083,7 @@
(d:get-item-by-psi *type-psi*)))
(is (eql (d:instance-of type-assoc)
(d:get-item-by-psi *type-instance-psi*)))
- (is (= (length (d:roles type-assoc)) 2))
+ (is (= (length (d:roles type-assoc :revision 0)) 2))
(is (= (length (d:psis first-node)) 1))
(is (= (length (d:psis first-type)) 1))
(is (string= (d:uri (first (d:psis first-node)))
@@ -1095,19 +1098,24 @@
tm-id revision-3
:document-id document-id))
(let ((first-node (get-item-by-id "http://test-tm/first-node"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(first-type (get-item-by-id "http://test-tm/first-type"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(second-node (get-item-by-id "second-node"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(second-type (get-item-by-id "http://test-tm/second-type"
- :xtm-id document-id))
+ :xtm-id document-id
+ :revision 0))
(third-node (get-item-by-id "http://test-tm#third-node"
- :xtm-id document-id)))
+ :xtm-id document-id
+ :revision 0)))
(is-true second-node)
- (is-false (d:psis second-node))
- (is-false (d:occurrences second-node))
- (is-false (d:names second-node))
+ (is-false (d:psis second-node :revision 0))
+ (is-false (d:occurrences second-node :revision 0))
+ (is-false (d:names second-node :revision 0))
(is-true first-node)
(is (= (length (d::versions first-node)) 2))
(is-true (find-if #'(lambda(x)
@@ -1119,18 +1127,22 @@
(= (d::end-revision x) 0)))
(d::versions first-node)))
(let ((instance-role
- (first (d:player-in-roles first-node)))
+ (first (d:player-in-roles first-node :revision 0)))
(type-role
- (first (d:player-in-roles first-type)))
+ (first (d:player-in-roles first-type :revision 0)))
(type-assoc
- (d:parent (first (d:player-in-roles first-node))))
- (type-topic (get-item-by-psi *type-psi*))
- (instance-topic (get-item-by-psi *instance-psi*))
- (type-instance-topic (get-item-by-psi *type-instance-psi*))
- (supertype-topic (get-item-by-psi *supertype-psi*))
- (subtype-topic (get-item-by-psi *subtype-psi*))
+ (d:parent (first (d:player-in-roles first-node
+ :revision 0))))
+ (type-topic (get-item-by-psi *type-psi* :revision 0))
+ (instance-topic (get-item-by-psi *instance-psi* :revision 0))
+ (type-instance-topic (get-item-by-psi *type-instance-psi*
+ :revision 0))
+ (supertype-topic (get-item-by-psi *supertype-psi*
+ :revision 0))
+ (subtype-topic (get-item-by-psi *subtype-psi*
+ :revision 0))
(supertype-subtype-topic
- (get-item-by-psi *supertype-subtype-psi*))
+ (get-item-by-psi *supertype-subtype-psi* :revision 0))
(arc2-occurrence (elephant:get-instance-by-value
'd:OccurrenceC 'd:charvalue "arc-2"))
(arc3-occurrence
@@ -1138,18 +1150,19 @@
'd:OccurrenceC 'd:charvalue
"<root><content type=\"anyContent\">content</content></root>"))
(fifth-node (d:get-item-by-id "http://test-tm#fifth-node"
- :xtm-id document-id)))
- (is (eql (d:instance-of instance-role)
- (d:get-item-by-psi *instance-psi*)))
- (is (eql (d:instance-of type-role)
- (d:get-item-by-psi *type-psi*)))
- (is (eql (d:instance-of type-assoc)
- (d:get-item-by-psi *type-instance-psi*)))
- (is (= (length (d:roles type-assoc)) 2))
- (is (= (length (d:psis first-node)) 1))
- (is (= (length (d:psis first-type)) 1))
- (is (= (length (d::versions type-assoc)) 1))
- (is (= (length (d:player-in-roles second-node)) 2))
+ :xtm-id document-id
+ :revision 0)))
+ (is (eql (d:instance-of instance-role :revision 0)
+ (d:get-item-by-psi *instance-psi* :revision 0)))
+ (is (eql (d:instance-of type-role :revision 0)
+ (d:get-item-by-psi *type-psi* :revision 0)))
+ (is (eql (d:instance-of type-assoc :revision 0)
+ (d:get-item-by-psi *type-instance-psi* :revision 0)))
+ (is (= (length (d:roles type-assoc :revision 0)) 2))
+ (is (= (length (d:psis first-node :revision 0)) 1))
+ (is (= (length (d:psis first-type :revision 0)) 1))
+ (is (= (length (d::versions type-assoc)) 2))
+ (is (= (length (d:player-in-roles second-node :revision 0)) 2))
(is-true (find-if
#'(lambda(x)
(and (eql (d:instance-of x) instance-topic)
@@ -1176,16 +1189,16 @@
(d:player-in-roles third-node)))
(is-true arc2-occurrence)
(is (string= (d:datatype arc2-occurrence) "http://test-tm/dt"))
- (is-false (d:psis (d:topic arc2-occurrence)))
- (is (= (length (d::versions (d:topic arc2-occurrence))) 1))
+ (is-false (d:psis (d:parent arc2-occurrence)))
+ (is (= (length (d::versions (d:parent arc2-occurrence))) 1))
(is (= (d::start-revision
- (first (d::versions (d:topic arc2-occurrence))))
+ (first (d::versions (d:parent arc2-occurrence))))
revision-3))
(is (= (d::end-revision
- (first (d::versions (d:topic arc2-occurrence)))) 0))
+ (first (d::versions (d:parent arc2-occurrence)))) 0))
(is-true arc3-occurrence)
- (is (= (length (d:psis (d:topic arc3-occurrence)))))
- (is (string= (d:uri (first (d:psis (d:topic arc3-occurrence))))
+ (is (= (length (d:psis (d:parent arc3-occurrence)))))
+ (is (string= (d:uri (first (d:psis (d:parent arc3-occurrence))))
"http://test-tm/fourth-node"))
(is (string= (d:datatype arc3-occurrence)
*xml-string*))
@@ -1592,8 +1605,8 @@
(concatenate 'string arcs "firstName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
goethe)))
occs)
1))
@@ -1604,8 +1617,8 @@
(concatenate 'string arcs "lastName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
goethe)))
occs)
1))
@@ -1616,8 +1629,8 @@
(concatenate 'string arcs "fullName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
weimar)))
occs)
1))
@@ -1628,8 +1641,8 @@
(concatenate 'string arcs "fullName"))
(string= *xml-string* (d:datatype x))
(= (length (d:themes x)) 0)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
frankfurt)))
occs)
1))
@@ -1641,8 +1654,8 @@
(string= *xml-string* (d:datatype x))
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
germany)))
occs)
1))
@@ -1655,8 +1668,8 @@
(string= (d:charvalue x) "Der Zauberlehrling")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
zauberlehrling)))
occs)
1))
@@ -1668,8 +1681,8 @@
(= 0 (length (d:themes x)))
(string= (d:charvalue x) "Prometheus")
(string= *xml-string* (d:datatype x))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
prometheus)))
occs)
1))
@@ -1682,8 +1695,8 @@
(string= (d:charvalue x) "Der Erlkönig")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
erlkoenig)))
occs)
1))
@@ -1696,8 +1709,8 @@
(string= (d:charvalue x) "Hat der alte Hexenmeister ...")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
zauberlehrling)))
occs)
1))
@@ -1711,8 +1724,8 @@
" Bedecke deinen Himmel, Zeus, ... ")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
prometheus)))
occs)
1))
@@ -1726,8 +1739,8 @@
"Wer reitet so spät durch Nacht und Wind? ...")
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
erlkoenig)))
occs)
1))
@@ -1738,8 +1751,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
weimar)))
occs)
1))
@@ -1750,8 +1763,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
frankfurt)))
occs)
1))
@@ -1762,8 +1775,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
berlin)))
occs)
1))
@@ -1774,8 +1787,8 @@
(concatenate 'string arcs "population"))
(string= long (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 1)
- (string= (d:uri (first (d:psis (d:topic x))))
+ (= (length (d:psis (d:parent x))) 1)
+ (string= (d:uri (first (d:psis (d:parent x))))
germany)))
occs)
1))
@@ -1786,7 +1799,7 @@
(concatenate 'string arcs "date"))
(string= date (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
2))
(is (= (count-if
@@ -1797,7 +1810,7 @@
(string= date (d:datatype x))
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
1))
@@ -1808,7 +1821,7 @@
(concatenate 'string arcs "start"))
(string= date (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
2))
@@ -1820,7 +1833,7 @@
(string= date (d:datatype x))
(= 1 (length (d:themes x)))
(eql (first (d:themes x)) de)
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
1))
(is (= (count-if
@@ -1830,7 +1843,7 @@
(concatenate 'string arcs "end"))
(string= date (d:datatype x))
(= 0 (length (d:themes x)))
- (= (length (d:psis (d:topic x))) 0)))
+ (= (length (d:psis (d:parent x))) 0)))
occs)
2)))))
@@ -2853,7 +2866,7 @@
(rdf-importer:rdf-importer rdf-file dir
:tm-id tm-id
:document-id document-id)
- (elephant:open-store (xml-importer:get-store-spec dir))
+ ;(elephant:open-store (xml-importer:get-store-spec dir))
(is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15))
(is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1))
(is (= (length (elephant:get-instances-by-class 'd:NameC)) 4))
@@ -2937,16 +2950,18 @@
(is-true marge-ln)
(is (string= (d:charvalue marge-fn) "Marjorie"))
(is (string= (d:charvalue marge-ln) "Simpson"))
- (is (= (length (d:variants marge-fn)) 1))
- (is (= (length (d:themes (first (d:variants marge-fn)))) 1))
- (is (eql (first (d:themes (first (d:variants marge-fn)))) display))
- (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge"))
- (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*))
+ (is (= (length (d:variants marge-fn :revision 0)) 1))
+ (is (= (length (d:themes (first (d:variants marge-fn :revision 0))
+ :revision 0)) 1))
+ (is (eql (first (d:themes (first (d:variants marge-fn :revision 0))
+ :revision 0)) display))
+ (is (string= (d:charvalue (first (d:variants marge-fn :revision 0))) "Marge"))
+ (is (string= (d:datatype (first (d:variants marge-fn :revision 0))) *xml-string*))
(is-true marge-occ)
(is (string= (d:charvalue marge-occ) "Housewife"))
(is (string= (d:datatype marge-occ) *xml-string*))
- (is (= (length (d:themes marge-occ)) 0))
- (is (= (length (d:psis marge)) 2))))))
+ (is (= (length (d:themes marge-occ :revision 0)) 0))
+ (is (= (length (d:psis marge :revision 0)) 2))))))
(test test-full-mapping-homer
Modified: branches/new-datamodel/src/xml/rdf/importer.lisp
==============================================================================
--- branches/new-datamodel/src/xml/rdf/importer.lisp (original)
+++ branches/new-datamodel/src/xml/rdf/importer.lisp Wed Oct 6 17:30:04 2010
@@ -72,7 +72,7 @@
(defun import-dom (rdf-dom start-revision
&key (tm-id nil) (document-id *document-id*))
- "Imports the entire dom of a rdf-xml-file."
+ "Imports the entire dom of an rdf-xml-file."
(setf *_n-map* nil) ;in case of an failed last call
(tm-id-p tm-id "import-dom")
(let ((xml-base (get-xml-base rdf-dom))
@@ -137,7 +137,7 @@
(defun import-arc (elem tm-id start-revision
&key (document-id *document-id*)
(parent-xml-base nil) (parent-xml-lang nil))
- "Imports a property that is an blank_node and continues the recursion
+ "Imports a property that is a blank_node and continues the recursion
on this element."
(declare (dom:element elem))
(let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang))
@@ -351,9 +351,11 @@
(error "~aone of the role types ~a ~a is missing!"
err-pref *supertype-psi* *subtype-psi*))
(let ((a-roles (list (list :instance-of role-type-1
- :player super-top)
+ :player super-top
+ :start-revision start-revision)
(list :instance-of role-type-2
- :player sub-top))))
+ :player sub-top
+ :start-revision start-revision))))
(let ((assoc
(add-to-tm
tm
@@ -392,9 +394,11 @@
(error "~aone of the role types ~a ~a is missing!"
err-pref *type-psi* *instance-psi*))
(let ((a-roles (list (list :instance-of roletype-1
- :player type-top)
+ :player type-top
+ :start-revision start-revision)
(list :instance-of roletype-2
- :player instance-top))))
+ :player instance-top
+ :start-revision start-revision))))
(let ((assoc
(add-to-tm
tm
@@ -420,40 +424,35 @@
(ii-uri (unless (or about ID)
(concatenate 'string *rdf2tm-blank-node-prefix*
(or nodeID UUID)))))
- (let ((top
- ;seems like there is a bug in d:get-item-by-id:
- ;this functions returns an emtpy topic although there is no one
- ;with a corresponding topic id and/or version.
- ;Thus the version is temporary checked manually.
- (let ((inner-top
- (get-item-by-id topic-id :xtm-id document-id
- :revision start-revision)))
- (when inner-top
- (let ((versions (d::versions inner-top)))
- (when (find-if #'(lambda(version)
- (= start-revision
- (d::start-revision version)))
- versions)
- inner-top))))))
+ (let ((top (get-item-by-id topic-id :xtm-id document-id
+ :revision start-revision)))
(if top
- top
+ (progn
+ (d::add-to-version-history top :start-revision start-revision)
+ top)
(elephant:ensure-transaction (:txn-nosync t)
(let ((psis (when psi-uri
(list
- (make-instance 'PersistentIdC
+ (make-construct 'PersistentIdC
:uri psi-uri
:start-revision start-revision))))
(iis (when ii-uri
(list
- (make-instance 'ItemIdentifierC
+ (make-construct 'ItemIdentifierC
:uri ii-uri
- :start-revision start-revision)))))
+ :start-revision start-revision))))
+ (topic-ids (when topic-id
+ (list
+ (make-construct 'TopicIdentificationC
+ :uri topic-id
+ :xtm-id document-id
+ :start-revision start-revision)))))
(handler-case (let ((top
(add-to-tm
tm
(make-construct
- 'TopicC
- :topicid topic-id
+ 'TopicC
+ :topic-identifiers topic-ids
:psis psis
:item-identifiers iis
:xtm-id document-id
@@ -498,9 +497,11 @@
(type-top (make-topic-stub type nil nil nil start-revision
tm :document-id document-id)))
(let ((roles (list (list :instance-of role-type-1
- :player player-1)
+ :player player-1
+ :start-revision start-revision)
(list :instance-of role-type-2
- :player top))))
+ :player top
+ :start-revision start-revision))))
(let ((assoc
(add-to-tm tm (make-construct 'AssociationC
:start-revision start-revision
@@ -527,9 +528,11 @@
(make-topic-stub *rdf2tm-object* nil nil nil start-revision
tm :document-id document-id)))
(let ((roles (list (list :instance-of role-type-1
- :player subject-topic)
+ :player subject-topic
+ :start-revision start-revision)
(list :instance-of role-type-2
- :player object-topic))))
+ :player object-topic
+ :start-revision start-revision))))
(let ((assoc
(add-to-tm
tm (make-construct 'AssociationC
@@ -541,13 +544,14 @@
-(defun make-reification(reifier-id reifiable-construct start-revision tm &key (document-id *document-id*))
+(defun make-reification(reifier-id reifiable-construct start-revision tm &key
+ (document-id *document-id*))
(declare (string reifier-id))
(declare (ReifiableConstructC reifiable-construct))
(declare (TopicMapC tm))
(let ((reifier-topic (make-topic-stub reifier-id nil nil nil start-revision tm
:document-id document-id)))
- (add-reifier reifiable-construct reifier-topic)))
+ (add-reifier reifiable-construct reifier-topic :revision start-revision)))
(defun make-occurrence (top literal start-revision tm-id
@@ -572,7 +576,7 @@
(let ((occurrence
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes (when lang-top
(list lang-top))
:instance-of type-top
Modified: branches/new-datamodel/src/xml/rdf/map_to_tm.lisp
==============================================================================
--- branches/new-datamodel/src/xml/rdf/map_to_tm.lisp (original)
+++ branches/new-datamodel/src/xml/rdf/map_to_tm.lisp Wed Oct 6 17:30:04 2010
@@ -57,42 +57,51 @@
(let ((type-topic (get-item-by-psi type-psi
:revision start-revision)))
(when type-topic
- (when (and (not (player-in-roles type-topic))
- (not (used-as-type type-topic))
- (not (used-as-theme type-topic)))
+ (when (and (not (player-in-roles type-topic :revision start-revision))
+ (not (used-as-type type-topic :revision start-revision))
+ (not (used-as-theme type-topic :revision start-revision)))
(d::delete-construct type-topic)))))
-(defun delete-instance-of-association(instance-topic type-topic)
+(defun delete-instance-of-association(instance-topic type-topic start-revision)
"Deletes a type-instance associaiton that corresponds with the passed
parameters."
(when (and instance-topic type-topic)
- (let ((instance (get-item-by-psi *instance-psi*))
- (type-instance (get-item-by-psi *type-instance-psi*))
- (type (get-item-by-psi *type-psi*)))
- (declare (TopicC instance-topic type-topic))
+ (let ((instance (get-item-by-psi *instance-psi* :revision start-revision))
+ (type-instance (get-item-by-psi *type-instance-psi*
+ :revision start-revision))
+ (type (get-item-by-psi *type-psi* :revision start-revision)))
+ (declare (TopicC instance-topic type-topic)
+ (integer start-revision))
(let ((assocs (remove-if
#'null
(map 'list
#'(lambda(role)
- (when (and (eql (instance-of role) instance)
- (eql (instance-of (parent role))
- type-instance))
- (parent role)))
- (player-in-roles instance-topic)))))
+ (when (and
+ (eql (instance-of role :revision start-revision)
+ instance)
+ (eql (instance-of
+ (parent role :revision start-revision)
+ :revision start-revision)
+ type-instance))
+ (parent role :revision start-revision)))
+ (player-in-roles instance-topic :revision start-revision)))))
(map 'list #'(lambda(assoc)
- (when (find-if #'(lambda(role)
- (and (eql (instance-of role) type)
- (eql (player role) type-topic)))
- (roles assoc))
+ (when (find-if
+ #'(lambda(role)
+ (and (eql (instance-of role :revision start-revision)
+ type)
+ (eql (player role :revision start-revision)
+ type-topic)))
+ (roles assoc :revision start-revision))
(d::delete-construct assoc)))
assocs)
nil))))
-(defun delete-related-associations (top)
+(defun delete-related-associations (top start-revision)
"Deletes all associaitons related to the passed topic."
- (dolist (assoc-role (player-in-roles top))
+ (dolist (assoc-role (player-in-roles top :revision start-revision))
(d::delete-construct (parent assoc-role)))
top)
@@ -141,11 +150,12 @@
(when (= 0 (length role-players))
(error "~aexpect one player but found: ~a"
err-pref (length role-players)))
- (delete-related-associations role-top)
+ (delete-related-associations role-top start-revision)
(d::delete-construct role-top)
(list :instance-of (first types)
:player (first role-players)
:item-identifiers ids
+ :start-revision start-revision
:reifiers reifiers)))))
@@ -185,7 +195,7 @@
(when (= 0 (length assoc-roles))
(error "~aexpect at least one role but found: ~a"
err-pref (length assoc-roles)))
- (delete-related-associations assoc-top)
+ (delete-related-associations assoc-top start-revision)
(d::delete-construct assoc-top)
(with-tm (start-revision document-id tm-id)
(add-to-tm
@@ -208,10 +218,11 @@
assoc-roles)))
(when found-item
(dolist (reifier-topic (getf found-item :reifiers))
- (add-reifier association-role reifier-topic)))))
- (roles association))
+ (add-reifier association-role reifier-topic
+ :revision start-revision)))))
+ (roles association :revision start-revision))
(dolist (reifier-topic reifier-topics)
- (add-reifier association reifier-topic))
+ (add-reifier association reifier-topic :revision start-revision))
association)))))))
@@ -267,7 +278,7 @@
variant-top start-revision *tm2rdf-scope-property*
*rdf2tm-subject*))
(value-type-topic
- (get-item-by-psi *tm2rdf-value-property*)))
+ (get-item-by-psi *tm2rdf-value-property* :revision start-revision)))
(let ((scopes (get-players-by-role-type
scope-assocs start-revision *rdf2tm-object*))
(value-and-datatype
@@ -283,7 +294,7 @@
(reifiers (get-isi-reifiers variant-top start-revision)))
(elephant:ensure-transaction (:txn-nosync t)
(map 'list #'d::delete-construct scope-assocs)
- (delete-related-associations variant-top)
+ (delete-related-associations variant-top start-revision)
(d::delete-construct variant-top)
(let ((variant
(make-construct 'VariantC
@@ -292,9 +303,9 @@
:themes scopes
:charvalue (getf value-and-datatype :value)
:datatype (getf value-and-datatype :datatype)
- :name name)))
+ :parent name)))
(dolist (reifier-topic reifiers)
- (add-reifier variant reifier-topic))
+ (add-reifier variant reifier-topic :revision start-revision))
variant)))))
@@ -312,7 +323,7 @@
name-top start-revision *tm2rdf-scope-property*
*rdf2tm-subject*))
(value-type-topic
- (get-item-by-psi *tm2rdf-value-property*))
+ (get-item-by-psi *tm2rdf-value-property* :revision start-revision))
(variant-topics (get-isi-variants name-top start-revision)))
(let ((type (let ((fn-types
(get-players-by-role-type
@@ -335,7 +346,7 @@
(map 'list #'d::delete-construct scope-assocs)
(let ((name (make-construct 'NameC
:start-revision start-revision
- :topic top
+ :parent top
:charvalue value
:instance-of type
:item-identifiers ids
@@ -344,10 +355,10 @@
(map-isi-variant name variant-topic
start-revision))
variant-topics)
- (delete-related-associations name-top)
+ (delete-related-associations name-top start-revision)
(d::delete-construct name-top)
(dolist (reifier-topic reifiers)
- (add-reifier name reifier-topic))
+ (add-reifier name reifier-topic :revision start-revision))
name)))))
@@ -403,19 +414,19 @@
(when (/= 1 (length types))
(error "~aexpect one type topic but found: ~a"
err-pref (length types)))
- (delete-related-associations occ-top)
+ (delete-related-associations occ-top start-revision)
(d::delete-construct occ-top)
(let ((occurrence
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes scopes
:item-identifiers ids
:instance-of (first types)
:charvalue (getf value-and-datatype :value)
:datatype (getf value-and-datatype :datatype))))
(dolist (reifier-topic reifiers)
- (add-reifier occurrence reifier-topic))
+ (add-reifier occurrence reifier-topic :revision start-revision))
occurrence)))))
@@ -448,12 +459,15 @@
(let ((topics-in-tm
(with-tm (start-revision document-id tm-id)
(intersection isi-topics (topics xml-importer::tm)))))
- (map 'list #'(lambda(top)
- (map 'list
- #'(lambda(role)
- (when (find (parent role) assocs)
- (d::delete-construct (parent role))))
- (player-in-roles top)))
+ (map 'list
+ #'(lambda(top)
+ (map 'list
+ #'(lambda(role)
+ (when (find (parent role :revision start-revision)
+ assocs)
+ (d::delete-construct
+ (parent role :revision start-revision))))
+ (player-in-roles top :revision start-revision)))
topics-in-tm)
topics-in-tm))))))
@@ -497,11 +511,13 @@
(map 'list
#'(lambda(assoc)
(let ((role
- (find-if #'(lambda(role)
- (eql role-type (instance-of role)))
- (roles assoc))))
+ (find-if
+ #'(lambda(role)
+ (eql role-type (instance-of role
+ :revision start-revision)))
+ (roles assoc :revision start-revision))))
(when role
- (player role))))
+ (player role :revision start-revision))))
associations))))
players)))
@@ -517,16 +533,18 @@
(remove-if #'null
(map 'list
#'(lambda(occurrence)
- (let ((type (instance-of occurrence)))
+ (let ((type
+ (instance-of occurrence
+ :revision start-revision)))
(let ((type-psi
(find-if #'(lambda(psi)
(string=
occurrence-type-uri
(uri psi)))
- (psis type))))
+ (psis type :revision start-revision))))
(when type-psi
occurrence))))
- (occurrences top)))))
+ (occurrences top :revision start-revision)))))
identifier-occs)))
@@ -566,11 +584,11 @@
(dolist (id identifiers)
(declare (ItemIdentifierC id))
(if (find-if #'(lambda(ii)
- (string= (uri ii) (uri id)))
- (item-identifiers construct))
+ (and (string= (uri ii) (uri id))
+ (not (eql ii id))))
+ (item-identifiers construct :revision start-revision))
(d::delete-construct id)
- (add-item-identifier (identified-construct id :revision start-revision)
- construct :revision start-revision)))
+ (add-item-identifier construct id :revision start-revision)))
construct)
@@ -580,11 +598,11 @@
(dolist (id identifiers)
(declare (PersistentIdC id))
(if (find-if #'(lambda(psi)
- (string= (uri psi) (uri id)))
- (psis top))
+ (and (string= (uri psi) (uri id))
+ (not (eql psi id))))
+ (psis top :revision start-revision))
(d::delete-construct id)
- (add-psi (identified-construct id :revision start-revision)
- top :revision start-revision)))
+ (add-psi top id :revision start-revision)))
top)
@@ -594,11 +612,11 @@
(dolist (id locators)
(declare (SubjectLocatorC id))
(if (find-if #'(lambda(locator)
- (string= (uri locator) (uri id)))
- (locators top))
+ (and (string= (uri locator) (uri id))
+ (not (eql locator id))))
+ (locators top :revision start-revision))
(d::delete-construct id)
- (add-locator (identified-construct id :revision start-revision)
- top :revision start-revision)))
+ (add-locator top id :revision start-revision)))
top)
More information about the Isidorus-cvs
mailing list