Author: lgiessmann Date: Sun Nov 22 13:16:47 2009 New Revision: 145 Log: added the support for reification in the xtm 2.0 importer Modified: trunk/src/model/datamodel.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Nov 22 13:16:47 2009 @@ -1615,6 +1615,7 @@ (merge-reifier-topics (reifier construct) reifier-topic)))))) construct)) + (defgeneric merge-reifier-topics (old-topic new-topic) ;;the reifier topics are not only merged but also bound to the reified-construct (:method ((old-topic TopicC) (new-topic TopicC)) @@ -1632,8 +1633,10 @@ (dolist (scoped-construct (used-as-theme new-topic)) (remove-association scoped-construct 'themes new-topic) (add-association scoped-construct 'themes old-topic)) + ;merges all topic-maps (dolist (tm (in-topicmaps new-topic)) (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it + ;merges all role-players (dolist (a-role (player-in-roles new-topic)) (remove-association a-role 'player new-topic) (add-association a-role 'player old-topic)) Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Sun Nov 22 13:16:47 2009 @@ -96,6 +96,20 @@ :topicid "name-type" :xtm-id xtm-id-1 :start-revision revision-1)) + (assoc-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-assoc-type" + :start-revision revision-1)) + :topicid "assoc-type" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (role-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-role-type" + :start-revision revision-1)) + :topicid "assoc-type" + :xtm-id xtm-id-1 + :start-revision revision-1)) (occurrence-type (make-construct 'TopicC :psis (list (make-instance 'PersistentIdC :uri "psi-occurrence-type" @@ -143,10 +157,29 @@ :themes (list scope-1 topic-2) :instance-of topic-2 :charvalue "test-name" - :start-revision revision-2))) - (is (= (length (elephant:get-instances-by-class 'TopicC)) 6)) + :start-revision revision-2)) + (assoc (make-construct 'AssociationC + :item-identifiers nil + :instance-of assoc-type + :themes nil + :roles + (list + (list :instance-of role-type + :player topic-1 + :item-identifiers + (list (make-instance 'ItemIdentifierC + :uri "role-1" + :start-revision revision-1))) + (list :instance-of role-type + :player topic-2 + :item-identifiers + (list (make-instance 'ItemIdentifierC + :uri "role-2" + :start-revision revision-1)))) + :start-revision revision-1))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 8)) (datamodel::merge-reifier-topics topic-1 topic-2) - (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 7)) (is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2) (item-identifiers topic-1))) (length (list ii-1-1 ii-1-2 ii-2-1 ii-2-2)))) @@ -168,11 +201,18 @@ (is (= (length (union (d:used-as-theme topic-1) (list test-name))) (length (list test-name)))) - ;;TODO: roleplayer, topicmap + (is (eql (player (first (roles assoc))) topic-1)) + (is (eql (player (second (roles assoc))) topic-1)) ;;TODO: check all objects and their version-infos (elephant:close-store)))))) +;;TODO: check xtm1.0 importer +;;TODO: check xtm2.0 importer +;;TODO: check rdf importer +;;TODO: check fragment exporter + + (defun run-reification-tests () (it.bese.fiveam:run! 'test-merge-reifier-topics) ) \ No newline at end of file Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Sun Nov 22 13:16:47 2009 @@ -9,6 +9,17 @@ (in-package :xml-importer) +(defun set-reifier (reifiable-elem reifiable-construct) + "Sets the reifier-topic of the passed elem to the passed construct." + (declare (dom:element reifiable-elem)) + (declare (ReifiableConstructC reifiable-construct)) + (let ((reifier-uri (get-attribute reifiable-elem "reifier"))) + (when (and (stringp reifier-uri) + (> (length reifier-uri) 0)) + (add-reifier reifiable-construct reifier-uri)) + reifiable-construct)) + + (defun from-identifier-elem (classsymbol elem start-revision) "Generate an identifier object of type 'classsymbol' (a subclass of IdentifierC) from a given identifier element for a revision and return @@ -127,7 +138,7 @@ :themes themes))) (loop for variant-elem across (xpath-child-elems-by-qname name-elem *xtm2.0-ns* "variant") do (from-variant-elem variant-elem name start-revision :xtm-id xtm-id)) - name))) + (set-reifier name-elem name)))) (defun from-resourceX-elem (parent-elem) @@ -180,13 +191,14 @@ (unless variant-value (error "VariantC: one of resourceRef and resourceData must be set")) - (make-construct 'VariantC - :start-revision start-revision - :item-identifiers item-identifiers - :themes themes - :charvalue (getf variant-value :data) - :datatype (getf variant-value :type) - :name name))) + (let ((variant (make-construct 'VariantC + :start-revision start-revision + :item-identifiers item-identifiers + :themes themes + :charvalue (getf variant-value :data) + :datatype (getf variant-value :type) + :name name))) + (set-reifier variant-elem variant)))) (defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*)) @@ -211,14 +223,15 @@ (occurrence-value (from-resourceX-elem occ-elem))) (unless occurrence-value (error "OccurrenceC: one of resourceRef and resourceData must be set")) - (make-construct 'OccurrenceC - :start-revision start-revision - :topic top - :themes themes - :item-identifiers item-identifiers - :instance-of instance-of - :charvalue (getf occurrence-value :data) - :datatype (getf occurrence-value :type)))) + (let ((occurrence (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes themes + :item-identifiers item-identifiers + :instance-of instance-of + :charvalue (getf occurrence-value :data) + :datatype (getf occurrence-value :type)))) + (set-reifier occ-elem occurrence)))) @@ -322,7 +335,13 @@ (xpath-single-child-elem-by-qname role-elem *xtm2.0-ns* - "topicRef")) :xtm-id xtm-id))) + "topicRef")) :xtm-id xtm-id)) + (reifier-uri + (let ((value (get-attribute role-elem "reifier"))) + (if (and (stringp value) + (> (length value) 0)) + value + nil)))) ; (unless (and player instance-of) ; (error "Role in association not complete")) (unless player ;instance-of will be set later - if there is no one @@ -331,7 +350,10 @@ role-elem *xtm2.0-ns* "topicRef")))) - (list :instance-of instance-of :player player :item-identifiers item-identifiers)))) + (list :reifier-uri reifier-uri + :instance-of instance-of + :player player + :item-identifiers item-identifiers)))) (defun from-association-elem (assoc-elem start-revision @@ -339,7 +361,7 @@ tm (xtm-id *current-xtm*)) "Constructs an AssociationC object from an association element -association = element association { reifiable, type, scope?, role+ }" + association = element association { reifiable, type, scope?, role+ }" (declare (dom:element assoc-elem)) (declare (integer start-revision)) (declare (TopicMapC tm)) @@ -366,14 +388,25 @@ assoc-elem *xtm2.0-ns* "role")))) (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them - - (add-to-topicmap tm - (make-construct 'AssociationC - :start-revision start-revision - :item-identifiers item-identifiers - :instance-of instance-of - :themes themes - :roles roles))))) + (let ((assoc (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :item-identifiers item-identifiers + :instance-of instance-of + :themes themes + :roles roles)))) + (map 'list #'(lambda(assoc-role) + (map 'list #'(lambda(list-role) + (when (and (eql (instance-of assoc-role) + (getf list-role :instance-of)) + (eql (player assoc-role) + (getf list-role :player)) + (getf list-role :reifier-uri)) + (add-reifier assoc-role (getf list-role :reifier-uri)))) + roles)) + (roles assoc)) + (set-reifier assoc-elem assoc)))))