isidorus-cvs

isidorus-cvs@common-lisp.net

1037 discussions

[isidorus-cvs] r144 - in trunk/src: . model unit_tests
by Lukas Giessmann 20 Nov '09

20 Nov '09

Author: lgiessmann Date: Fri Nov 20 05:41:32 2009 New Revision: 144 Log: added some unit-tests for the "reification"-functions; fixed some problems; currently there is still a problem with the versioning of constructs that existed more than one revision and were not merged at the initial version. Added: trunk/src/unit_tests/reification_test.lisp Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Fri Nov 20 05:41:32 2009 @@ -143,7 +143,9 @@ (:file "rdf_importer_test" :depends-on ("fixtures")) (:file "rdf_exporter_test" - :depends-on ("fixtures"))) + :depends-on ("fixtures")) + (:file "reification_test" + :depends-on ("fixtures" "unittests-constants"))) :depends-on ("atom" "constants" "model" Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri Nov 20 05:41:32 2009 @@ -621,80 +621,6 @@ (setf (slot-value construct 'reifier) topic) (setf (reified topic) construct))) -(defgeneric add-reifier (construct reifier-uri) - (:method ((construct ReifiableConstructC) reifier-uri) - (let ((err "From add-reifier(): ")) - (let ((item-identifier - (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri))) - (unless item-identifier - (error "~ano item-identifier could be found with the uri ~a" - err reifier-uri)) - (let ((reifier-topic (identified-construct item-identifier))) - (unless (typep reifier-topic 'TopicC) - (error "~anitem-identifier ~a must be bound to a topic, but is ~a" - err reifier-uri (type-of reifier-topic))) - (cond - ((and (not (reifier construct)) - (not (reified reifier-topic))) - (setf (reifier construct) reifier-topic) - (setf (reified reifier-topic) construct)) - ((and (not (reified reifier-topic)) - (reifier construct)) - (merge-reifier-topics (reifier construct) reifier-topic)) - ((and (not (reifier construct)) - (reified reifier-topic)) - (error "~a~a reifies already another object ~a" - err reifier-uri (reified reifier-topic))) - (t - (when (not (eql (reified reifier-topic) construct)) - (error "~a~a reifies already another object ~a" - err reifier-uri (reified reifier-topic))) - (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)) - (unless (eql old-topic new-topic) - ;merges all identifiers - (move-identifiers old-topic new-topic) - (move-identifiers old-topic new-topic :what 'locators) - (move-identifiers old-topic new-topic :what 'psis) - (move-identifiers old-topic new-topic :what 'topic-identifiers) - ;merges all typed-object-associations - (dolist (typed-construct (used-as-type new-topic)) - (remove-association typed-construct 'instance-of new-topic) - (add-association typed-construct 'instance-of old-topic)) - ;merges all scope-object-associations - (dolist (scoped-construct (used-as-theme new-topic)) - (remove-association scoped-construct 'theme new-topic) - (add-association scoped-construct 'theme old-topic)) - (dolist (tm (in-topicmaps new-topic)) - (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it - (dolist (a-role (player-in-roles new-topic)) - (remove-association a-role 'player new-topic) - (add-association a-role 'player old-topic)) - ;merges all names - (dolist (name (names new-topic)) - (remove-association name 'topic new-topic) - (add-association name 'topic old-topic)) - ;merges all occurrences - (dolist (occurrence (occurrences new-topic)) - (remove-association occurrence 'topic new-topic) - (add-association occurrence 'topic old-topic)) - ;merges all version-infos - (let ((versions-to-move - (loop for vrs in (versions new-topic) - when (not (find-if #'(lambda(x) - (and (= (start-revision x) (start-revision vrs)) - (= (end-revision x) (end-revision vrs)))) - (versions old-topic))) - collect vrs))) - (dolist (vrs versions-to-move) - (remove-association vrs 'versioned-construct new-topic) - (add-association vrs 'versioned-construct old-topic)))))) - - (defgeneric item-identifiers (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) @@ -1654,4 +1580,83 @@ (defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0)) (when (find-item-by-revision ass revision) - (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id))) \ No newline at end of file + (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id))) + +;;;;;;;;;;;;;;;;; +;; reification + +(defgeneric add-reifier (construct reifier-uri) + (:method ((construct ReifiableConstructC) reifier-uri) + (let ((err "From add-reifier(): ")) + (let ((item-identifier + (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri))) + (unless item-identifier + (error "~ano item-identifier could be found with the uri ~a" + err reifier-uri)) + (let ((reifier-topic (identified-construct item-identifier))) + (unless (typep reifier-topic 'TopicC) + (error "~anitem-identifier ~a must be bound to a topic, but is ~a" + err reifier-uri (type-of reifier-topic))) + (cond + ((and (not (reifier construct)) + (not (reified reifier-topic))) + (setf (reifier construct) reifier-topic)) + ((and (not (reified reifier-topic)) + (reifier construct)) + (merge-reifier-topics (reifier construct) reifier-topic)) + ((and (not (reifier construct)) + (reified reifier-topic)) + (error "~a~a reifies already another object ~a" + err reifier-uri (reified reifier-topic))) + (t + (when (not (eql (reified reifier-topic) construct)) + (error "~a~a reifies already another object ~a" + err reifier-uri (reified reifier-topic))) + (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)) + (unless (eql old-topic new-topic) + ;merges all identifiers + (move-identifiers old-topic new-topic) + (move-identifiers old-topic new-topic :what 'locators) + (move-identifiers old-topic new-topic :what 'psis) + (move-identifiers old-topic new-topic :what 'topic-identifiers) + ;merges all typed-object-associations + (dolist (typed-construct (used-as-type new-topic)) + (remove-association typed-construct 'instance-of new-topic) + (add-association typed-construct 'instance-of old-topic)) + ;merges all scope-object-associations + (dolist (scoped-construct (used-as-theme new-topic)) + (remove-association scoped-construct 'themes new-topic) + (add-association scoped-construct 'themes old-topic)) + (dolist (tm (in-topicmaps new-topic)) + (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it + (dolist (a-role (player-in-roles new-topic)) + (remove-association a-role 'player new-topic) + (add-association a-role 'player old-topic)) + ;merges all names + (dolist (name (names new-topic)) + (remove-association name 'topic new-topic) + (add-association name 'topic old-topic)) + ;merges all occurrences + (dolist (occurrence (occurrences new-topic)) + (remove-association occurrence 'topic new-topic) + (add-association occurrence 'topic old-topic)) + ;merges all version-infos + (let ((versions-to-move + (loop for vrs in (versions new-topic) + when (not (find-if #'(lambda(x) + (and (= (start-revision x) (start-revision vrs)) + (= (end-revision x) (end-revision vrs)))) + (versions old-topic))) + collect vrs))) + (dolist (vrs versions-to-move) + (remove-association vrs 'versioned-construct new-topic) + (add-association vrs 'versioned-construct old-topic))) + (delete-construct new-topic)) + ;TODO: order/repair all version-infos of the topic itself and add all new + ; versions to the original existing objects of the topic + old-topic)) \ No newline at end of file Added: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/reification_test.lisp Fri Nov 20 05:41:32 2009 @@ -0,0 +1,178 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(defpackage :reification-test + (:use + :common-lisp + :datamodel + :it.bese.FiveAM + :unittests-constants + :fixtures) + (:export + :reification-test + :run-reification-tests + :test-merge-reifier-topics)) + + +(in-package :reification-test) + + +(def-suite reification-test + :description "tests various functions of the reification functions") + +(in-suite reification-test) + + +(test test-merge-reifier-topics + "Tests the function merge-reifier-topics." + (let ((db-dir "data_base") + (revision-1 100) + (revision-2 200)) + (clean-out-db db-dir) + (elephant:open-store (xml-importer:get-store-spec db-dir)) + (let ((ii-1-1 (make-instance 'ItemIdentifierC + :uri "ii-1-1" + :start-revision revision-1)) + (ii-1-2 (make-instance 'ItemIdentifierC + :uri "ii-1-2" + :start-revision revision-1)) + (ii-2-1 (make-instance 'ItemIdentifierC + :uri "ii-2-1" + :start-revision revision-2)) + (ii-2-2 (make-instance 'ItemIdentifierC + :uri "ii-2-2" + :start-revision revision-2)) + (psi-1-1 (make-instance 'PersistentIdC + :uri "psi-1-1" + :start-revision revision-1)) + (psi-1-2 (make-instance 'PersistentIdC + :uri "psi-1-2" + :start-revision revision-1)) + (locator-2-1 (make-instance 'SubjectLocatorC + :uri "locator-2-1" + :start-revision revision-2)) + (xtm-id-1 "xtm-id-1") + (xtm-id-2 "xtm-id-2") + (topic-id-1 "topic-id-1") + (topic-id-2 "topic-id-1")) ;should no be merged, since the xtm-id differs + (let ((topic-1 (make-construct 'TopicC + :item-identifiers (list ii-1-1 ii-1-2) + :locators nil + :psis (list psi-1-1 psi-1-2) + :topicid topic-id-1 + :xtm-id xtm-id-1 + :start-revision revision-1)) + (topic-2 (make-construct 'TopicC + :item-identifiers (list ii-2-1 ii-2-2) + :locators (list locator-2-1) + :psis nil + :topicid topic-id-2 + :xtm-id xtm-id-2 + :start-revision revision-2)) + (scope-1 (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-scope-1" + :start-revision revision-1)) + :topicid "scope-1" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (scope-2 (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-scope-2" + :start-revision revision-1)) + :topicid "scope-2" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (name-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-name-type" + :start-revision revision-1)) + :topicid "name-type" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (occurrence-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-occurrence-type" + :start-revision revision-1)) + :topicid "occurrence-type" + :xtm-id xtm-id-1 + :start-revision revision-1))) + (let ((name-1-1 (make-construct 'NameC + :item-identifiers nil + :topic topic-1 + :themes (list scope-1) + :instance-of name-type + :charvalue "name-1-1" + :start-revision revision-1)) + (name-2-1 (make-construct 'NameC + :item-identifiers (list (make-instance 'ItemIdentifierC + :uri "name-2-1-ii-1" + :start-revision revision-1)) + :topic topic-2 + :themes (list scope-2) + :instance-of nil + :charvalue "name-2-1" + :start-revision revision-2)) + (occurrence-2-1 (make-construct 'OccurrenceC + :item-identifiers (list (make-instance 'ItemIdentifierC + :uri "occurrence-1-1-ii-1" + :start-revision revision-1)) + :topic topic-2 + :themes (list scope-1 scope-2) + :instance-of occurrence-type + :charvalue "occurrence-2-1" + :datatype "datatype" + :start-revision revision-2)) + (occurrence-2-2 (make-construct 'OccurrenceC + :item-identifiers nil + :topic topic-2 + :themes nil + :instance-of occurrence-type + :charvalue "occurrence-2-2" + :datatype "datatype" + :start-revision revision-2)) + (test-name (make-construct 'NameC + :item-identifiers nil + :topic scope-2 + :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)) + (datamodel::merge-reifier-topics topic-1 topic-2) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (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)))) + (is (= (length (union (list psi-1-1 psi-1-2) + (psis topic-1))) + (length (list psi-1-1 psi-1-2)))) + (is (= (length (union (list locator-2-1) + (locators topic-1))) + (length (list locator-2-1)))) + (is (= (length (union (names topic-1) + (list name-1-1 name-2-1))) + (length (list name-1-1 name-2-1)))) + (is (= (length (union (occurrences topic-1) + (list occurrence-2-1 occurrence-2-2))) + (length (list occurrence-2-1 occurrence-2-2)))) + (is (= (length (union (d:used-as-type topic-1) + (list test-name))) + (length (list test-name)))) + (is (= (length (union (d:used-as-theme topic-1) + (list test-name))) + (length (list test-name)))) + ;;TODO: roleplayer, topicmap + ;;TODO: check all objects and their version-infos + (elephant:close-store)))))) + + +(defun run-reification-tests () + (it.bese.fiveam:run! 'test-merge-reifier-topics) + ) \ No newline at end of file

1 0

[isidorus-cvs] r143 - trunk/src/model
by Lukas Giessmann 17 Nov '09

17 Nov '09

Author: lgiessmann Date: Tue Nov 17 14:02:13 2009 New Revision: 143 Log: added a function to merge reifier-topics. unit-tests are currently missing. the add-refier function can be used by all importers in the "merge-topic"-functions. Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 17 14:02:13 2009 @@ -631,7 +631,7 @@ err reifier-uri)) (let ((reifier-topic (identified-construct item-identifier))) (unless (typep reifier-topic 'TopicC) - (error "~aitem-identifier ~a must be bound to a topic, but is ~a" + (error "~anitem-identifier ~a must be bound to a topic, but is ~a" err reifier-uri (type-of reifier-topic))) (cond ((and (not (reifier construct)) @@ -640,8 +640,7 @@ (setf (reified reifier-topic) construct)) ((and (not (reified reifier-topic)) (reifier construct)) - ;merge topics - t) + (merge-reifier-topics (reifier construct) reifier-topic)) ((and (not (reifier construct)) (reified reifier-topic)) (error "~a~a reifies already another object ~a" @@ -650,23 +649,50 @@ (when (not (eql (reified reifier-topic) construct)) (error "~a~a reifies already another object ~a" err reifier-uri (reified reifier-topic))) - ;merge both topics or throw an error - t))))) + (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)) - ;move all item-identifiers to the new topic ;check if they are already existing - ;move all subject-locators to the new topic ;check if they are already existing - ;move all subject-identifiers to the new topic ;check if they are already existing - ;move all names to the new topic ;check if they are already existing - ;move all occurrences to the new topic ;check if they are already existing - ;check all objects where the topic is the type of - ;check all roles where the topic is a player of - ;check all objects where the topic is a scope of - (format t "~a~a" old-topic new-topic) - )) + (unless (eql old-topic new-topic) + ;merges all identifiers + (move-identifiers old-topic new-topic) + (move-identifiers old-topic new-topic :what 'locators) + (move-identifiers old-topic new-topic :what 'psis) + (move-identifiers old-topic new-topic :what 'topic-identifiers) + ;merges all typed-object-associations + (dolist (typed-construct (used-as-type new-topic)) + (remove-association typed-construct 'instance-of new-topic) + (add-association typed-construct 'instance-of old-topic)) + ;merges all scope-object-associations + (dolist (scoped-construct (used-as-theme new-topic)) + (remove-association scoped-construct 'theme new-topic) + (add-association scoped-construct 'theme old-topic)) + (dolist (tm (in-topicmaps new-topic)) + (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it + (dolist (a-role (player-in-roles new-topic)) + (remove-association a-role 'player new-topic) + (add-association a-role 'player old-topic)) + ;merges all names + (dolist (name (names new-topic)) + (remove-association name 'topic new-topic) + (add-association name 'topic old-topic)) + ;merges all occurrences + (dolist (occurrence (occurrences new-topic)) + (remove-association occurrence 'topic new-topic) + (add-association occurrence 'topic old-topic)) + ;merges all version-infos + (let ((versions-to-move + (loop for vrs in (versions new-topic) + when (not (find-if #'(lambda(x) + (and (= (start-revision x) (start-revision vrs)) + (= (end-revision x) (end-revision vrs)))) + (versions old-topic))) + collect vrs))) + (dolist (vrs versions-to-move) + (remove-association vrs 'versioned-construct new-topic) + (add-association vrs 'versioned-construct old-topic)))))) (defgeneric item-identifiers (construct &key revision) @@ -1050,6 +1076,39 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))) +(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers)) + "Moves all identifiers from the source-topic to the destination topic." + (declare (TopicC destination-topic source-topic)) + (let ((all-source-identifiers + (cond + ((eql what 'item-identifiers) + (item-identifiers source-topic)) + ((eql what 'locators) + (locators source-topic)) + (t + (psis source-topic)))) + (all-destination-identifiers + (cond + ((eql what 'item-identifiers) + (item-identifiers destination-topic)) + ((eql what 'locators) + (locators destination-topic)) + ((eql what 'psis) + (psis destination-topic)) + ((eql what 'topic-identifiers) + (topic-identifiers destination-topic))))) + (let ((identifiers-to-move + (loop for id in all-source-identifiers + when (not (find-if #'(lambda(x) + (if (eql what 'topic-identifiers) + (string= (xtm-id x) (xtm-id id)) + (string= (uri x) (uri id)))) + all-destination-identifiers)) + collect id))) + (dolist (item identifiers-to-move) + (remove-association source-topic what item) + (add-association destination-topic what item))))) + (defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis))

1 0

[isidorus-cvs] r142 - trunk/src/model
by Lukas Giessmann 17 Nov '09

17 Nov '09

Author: lgiessmann Date: Tue Nov 17 06:21:40 2009 New Revision: 142 Log: added the generic function add-reifier which adds a reifier to a reifiable object. currently this function does not merge reifier-topics Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 17 06:21:40 2009 @@ -103,6 +103,7 @@ :create-latest-fragment-of-topic :reified :reifier + :add-reifier :*current-xtm* ;; special variables :*TM-REVISION* @@ -620,6 +621,54 @@ (setf (slot-value construct 'reifier) topic) (setf (reified topic) construct))) +(defgeneric add-reifier (construct reifier-uri) + (:method ((construct ReifiableConstructC) reifier-uri) + (let ((err "From add-reifier(): ")) + (let ((item-identifier + (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri))) + (unless item-identifier + (error "~ano item-identifier could be found with the uri ~a" + err reifier-uri)) + (let ((reifier-topic (identified-construct item-identifier))) + (unless (typep reifier-topic 'TopicC) + (error "~aitem-identifier ~a must be bound to a topic, but is ~a" + err reifier-uri (type-of reifier-topic))) + (cond + ((and (not (reifier construct)) + (not (reified reifier-topic))) + (setf (reifier construct) reifier-topic) + (setf (reified reifier-topic) construct)) + ((and (not (reified reifier-topic)) + (reifier construct)) + ;merge topics + t) + ((and (not (reifier construct)) + (reified reifier-topic)) + (error "~a~a reifies already another object ~a" + err reifier-uri (reified reifier-topic))) + (t + (when (not (eql (reified reifier-topic) construct)) + (error "~a~a reifies already another object ~a" + err reifier-uri (reified reifier-topic))) + ;merge both topics or throw an error + t))))) + construct)) + + +(defgeneric merge-reifier-topics (old-topic new-topic) + (:method ((old-topic TopicC) (new-topic TopicC)) + ;move all item-identifiers to the new topic ;check if they are already existing + ;move all subject-locators to the new topic ;check if they are already existing + ;move all subject-identifiers to the new topic ;check if they are already existing + ;move all names to the new topic ;check if they are already existing + ;move all occurrences to the new topic ;check if they are already existing + ;check all objects where the topic is the type of + ;check all roles where the topic is a player of + ;check all objects where the topic is a scope of + (format t "~a~a" old-topic new-topic) + )) + + (defgeneric item-identifiers (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision)))

1 0

[isidorus-cvs] r141 - in trunk/src: model unit_tests
by Lukas Giessmann 10 Sep '09

10 Sep '09

Author: lgiessmann Date: Thu Sep 10 06:12:47 2009 New Revision: 141 Log: datamodel: added a 1:1 elephant-assocation to ReifiableConstructC and TopicC realizing reification; extended the functions delete-construct and initialize-instance of the affected classes Modified: trunk/src/model/datamodel.lisp trunk/src/unit_tests/importer_test.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Thu Sep 10 06:12:47 2009 @@ -101,6 +101,8 @@ :variants :xor :create-latest-fragment-of-topic + :reified + :reifier :*current-xtm* ;; special variables :*TM-REVISION* @@ -372,11 +374,11 @@ (symbol-value '*TM-REVISION*)) (t 0))) (properties (slot-value construct slot-name))) - ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) + ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) (cond ((not properties) nil) ;if we don't have any properties, we don't have to worry - ;about revisions + ;about revisions ((= 0 revision) (remove nil @@ -599,26 +601,45 @@ :inherit t :documentation "Slot that realizes a 1 to N relation between reifiable constructs and their - identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")) + identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs") + (reifier + :associate TopicC + :inherit t + :documentation "Represents a reifier association to a topic, i.e. + it stands for a 1:1 association between this class and TopicC")) (:documentation "Reifiable constructs as per TMDM")) + +(defgeneric reifier (construct &key revision) + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (when (slot-boundp construct 'reifier) + (filter-slot-value-by-revision construct 'reifier :start-revision revision)))) + +(defgeneric (setf reifier) (topic TopicC) + (:method (topic (construct ReifiableConstructC)) + (setf (slot-value construct 'reifier) topic) + (setf (reified topic) construct))) + (defgeneric item-identifiers (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) -(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil)) +(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil)) "adds associations to these ids after the instance was initialized." (declare (list item-identifiers)) (call-next-method) (dolist (id item-identifiers) (declare (ItemIdentifierC id)) (setf (identified-construct id) instance)) + (when reifier + (setf (reifier instance) reifier)) instance) - (defmethod delete-construct :before ((construct ReifiableConstructC)) (dolist (id (item-identifiers construct)) - (delete-construct id))) + (delete-construct id)) + (when (reifier construct) + (slot-makunbound (reifier construct) 'reified))) (defgeneric item-identifiers-p (constr) (:documentation "Test for the existence of item identifiers") @@ -928,9 +949,23 @@ (in-topicmaps :associate (TopicMapC topics) :many-to-many t - :documentation "list of all topic maps this topic is part of")) + :documentation "list of all topic maps this topic is part of") + (reified + :associate ReifiableConstructC + :documentation "contains a reified object, represented as 1:1 association")) (:documentation "Topic in a Topic Map")) + +(defgeneric reified (topic &key revision) + (:method ((topic TopicC) &key (revision *TM-REVISION*)) + (when (slot-boundp topic 'reified) + (filter-slot-value-by-revision topic 'reified :start-revision revision)))) + +(defgeneric (setf reified) (reifiable ReifiableConstructC) + (:method (reifiable (topic TopicC)) + (setf (slot-value topic 'reified) reifiable) + (setf (reifier reifiable) topic))) + (defgeneric occurrences (topic &key revision) (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'occurrences :start-revision revision))) @@ -966,19 +1001,21 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))) -(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil)) +(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis)) (declare (list locators)) (call-next-method) - ;item-identifiers are handled in the around-method for ReifiableConstructs, - ;TopicIdentificationCs are handled in make-construct of TopicC + ;item-identifiers are handled in the around-method for ReifiableConstructs, + ;TopicIdentificationCs are handled in make-construct of TopicC (dolist (persistent-id psis) (declare (PersistentIdC persistent-id)) (setf (identified-construct persistent-id) instance)) (dolist (subject-locator locators) (declare (SubjectLocatorC subject-locator)) - (setf (identified-construct subject-locator) instance))) + (setf (identified-construct subject-locator) instance)) + (when reified + (setf (reified instance) reified))) (defmethod delete-construct :before ((construct TopicC)) @@ -993,7 +1030,9 @@ (dolist (theme (used-as-theme construct)) (elephant:remove-association construct 'used-as-theme theme)) (dolist (tm (in-topicmaps construct)) - (elephant:remove-association construct 'in-topicmaps tm))) + (elephant:remove-association construct 'in-topicmaps tm)) + (when (reified construct) + (slot-makunbound (reified construct) 'reifier))) (defun get-all-constructs-by-uri (uri) (delete Modified: trunk/src/unit_tests/importer_test.lisp ============================================================================== --- trunk/src/unit_tests/importer_test.lisp (original) +++ trunk/src/unit_tests/importer_test.lisp Thu Sep 10 06:12:47 2009 @@ -662,6 +662,5 @@ ;as (importer-test:run-importer-tests) (defun run-importer-tests () (run! 'importer-test)) -;or (it.bese.fiveam.run! )

1 0

[isidorus-cvs] r140 - trunk/src/unit_tests
by Lukas Giessmann 09 Sep '09

09 Sep '09

Author: lgiessmann Date: Wed Sep 9 03:56:23 2009 New Revision: 140 Log: unit-tests: added functions of the for run-<module-name>-tests to all unit-tests without such a function -> consiteny Modified: trunk/src/unit_tests/atom_test.lisp trunk/src/unit_tests/versions_test.lisp Modified: trunk/src/unit_tests/atom_test.lisp ============================================================================== --- trunk/src/unit_tests/atom_test.lisp (original) +++ trunk/src/unit_tests/atom_test.lisp Wed Sep 9 03:56:23 2009 @@ -28,7 +28,9 @@ duplicate-identifier-error) (:export :atom-test :test-feed-to-string - :test-collection-configuration)) + :test-collection-configuration + :test-changes-feeds + :run-atom-tests)) ;test configuration (in-package :atom-test) @@ -204,3 +206,8 @@ (mapcar #'type-of collection-entries))) ))) + +(defun run-atom-tests() + (it.bese.fiveam:run! 'test-feed-to-string) + (it.bese.fiveam:run! 'test-changes-feeds) + (it.bese.fiveam:run! 'test-collection-configuration)) \ No newline at end of file Modified: trunk/src/unit_tests/versions_test.lisp ============================================================================== --- trunk/src/unit_tests/versions_test.lisp (original) +++ trunk/src/unit_tests/versions_test.lisp Wed Sep 9 03:56:23 2009 @@ -32,7 +32,7 @@ :test-change-lists :test-changed-p :versions-test - )) + :run-versions-tests)) (declaim (optimize (debug 3))) (in-package :versions-test) @@ -363,4 +363,12 @@ :revision (1+ fixtures::revision3)))))) - \ No newline at end of file + +(defun run-versions-tests() + (it.bese.fiveam:run! 'test-get-item-by-id-t100) + (it.bese.fiveam:run! 'test-get-item-by-id-t301) + (it.bese.fiveam:run! 'test-norwegian-curriculum-association) + (it.bese.fiveam:run! 'test-instance-of-t64) + (it.bese.fiveam:run! 'test-change-lists) + (it.bese.fiveam:run! 'test-changed-p) + (it.bese.fiveam:run! 'test-mark-as-deleted)) \ No newline at end of file

1 0

[isidorus-cvs] r139 - trunk/src/xml/rdf
by Lukas Giessmann 09 Sep '09

09 Sep '09

Author: lgiessmann Date: Wed Sep 9 03:42:00 2009 New Revision: 139 Log: rdf-importer: fixed a bug with xml:base and xml:lang; renamed some parameters for a better understanding Modified: trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Sep 9 03:42:00 2009 @@ -84,31 +84,36 @@ (let ((children (child-nodes-or-text rdf-dom :trim t))) (when children (loop for child across children - do (import-node child tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang))) + do (import-node child tm-id start-revision + :document-id document-id + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) + (import-node rdf-dom tm-id start-revision + :document-id document-id + :parent-xml-base xml-base + :parent-xml-lang xml-lang))) (setf *_n-map* nil)) (defun import-node (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) + "Imports an RDF node with all its properties and 'child' RDF nodes." (tm-id-p tm-id "import-node") (parse-node elem) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))) - (let ((about (get-absolute-attribute elem tm-id xml-base "about")) - (nodeID (get-ns-attribute elem "nodeID")) - (ID (get-absolute-attribute elem tm-id xml-base "ID")) - (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) - (parse-properties-of-node elem (or about nodeID ID UUID)) - - (let ((literals (append (get-literals-of-node elem fn-xml-lang) + (let ((about (get-absolute-attribute elem tm-id parent-xml-base "about")) + (nodeID (get-ns-attribute elem "nodeID")) + (ID (get-absolute-attribute elem tm-id parent-xml-base "ID")) + (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) + (parse-properties-of-node elem (or about nodeID ID UUID)) + (let ((literals (append (get-literals-of-node elem parent-xml-lang) (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) - (associations (get-associations-of-node-content elem tm-id xml-base)) - (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) + elem tm-id parent-xml-base parent-xml-lang))) + (associations (get-associations-of-node-content elem tm-id + parent-xml-base)) + (types (get-types-of-node elem tm-id + :parent-xml-base parent-xml-base)) (super-classes - (get-super-classes-of-node-content elem tm-id xml-base))) + (get-super-classes-of-node-content elem tm-id parent-xml-base))) (with-tm (start-revision document-id tm-id) (let ((this (make-topic-stub @@ -124,19 +129,18 @@ start-revision :document-id document-id) (make-recursion-from-node elem tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) - this)))))) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) + this))))) (defun import-arc (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Imports a property that is an blank_node and continues the recursion on this element." (declare (dom:element elem)) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) - (fn-xml-base (get-xml-base elem :old-base xml-base)) + (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) (parseType (get-ns-attribute elem "parseType")) (content (child-nodes-or-text elem :trim t))) @@ -156,24 +160,26 @@ :revision start-revision))) (let ((literals (append (get-literals-of-property - elem fn-xml-lang) + elem xml-lang) (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) + elem tm-id parent-xml-base + parent-xml-lang))) (associations (get-associations-of-node-content - elem tm-id xml-base)) + elem tm-id parent-xml-base)) (types (remove-if #'null (append - (get-types-of-node-content elem tm-id fn-xml-base) + (get-types-of-node-content elem tm-id + parent-xml-base) (when (get-ns-attribute elem "type") (list :ID nil :topicid (get-ns-attribute elem "type") :psi (get-ns-attribute elem "type")))))) (super-classes (get-super-classes-of-node-content - elem tm-id xml-base))) + elem tm-id parent-xml-base))) (make-literals this literals tm-id start-revision :document-id document-id) (make-associations this associations xml-importer::tm @@ -186,19 +192,20 @@ this))))) (make-recursion-from-arc elem tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) this-topic))))) (defun make-collection (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Creates a collection structure of a node that contains parseType='Collection." (declare (dom:element elem)) (with-tm (start-revision document-id tm-id) - (let ((fn-xml-base (get-xml-base elem :old-base xml-base)) - (fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) + (let ((xml-base (get-xml-base elem :old-base parent-xml-base)) + (xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (let ((this (make-topic-stub nil nil nil UUID start-revision xml-importer::tm @@ -206,8 +213,8 @@ (items (loop for item across (child-nodes-or-text elem :trim t) collect (import-node item tm-id start-revision :document-id document-id - :xml-base fn-xml-base - :xml-lang fn-xml-lang)))) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) (let ((last-blank-node this)) (dotimes (index (length items)) (let ((is-end @@ -466,10 +473,6 @@ (when lang (let ((psi-and-topic-id (concatenate-uri *rdf2tm-scope-prefix* lang))) - ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id -; :revision start-revision))) -; (if top -; top (make-topic-stub psi-and-topic-id nil nil nil start-revision tm :document-id document-id)))) @@ -612,13 +615,13 @@ occurrence)))))) -(defun get-literals-of-node-content (node tm-id xml-base xml-lang) +(defun get-literals-of-node-content (node tm-id parent-xml-base parent-xml-lang) "Returns a list of literals that is produced of a node's content." (declare (dom:element node)) (tm-id-p tm-id "get-literals-of-noode-content") (let ((properties (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base)) - (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) + (xml-base (get-xml-base node :old-base parent-xml-base)) + (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) (let ((literals (when properties (loop for property across properties @@ -643,11 +646,11 @@ (string/= parseType "Resource"))) collect (let ((content (child-nodes-or-text property)) (ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (child-xml-lang - (get-xml-lang property :old-lang fn-xml-lang))) + (get-xml-lang property :old-lang xml-lang))) (let ((full-name (get-type-of-node-name property)) - (datatype (get-datatype property tm-id fn-xml-base)) + (datatype (get-datatype property tm-id xml-base)) (text (cond ((= (length content) 0) @@ -670,18 +673,18 @@ literals))) -(defun get-types-of-node-content (node tm-id xml-base) +(defun get-types-of-node-content (node tm-id parent-xml-base) "Returns a list of type-uris that corresponds to the node's content or attributes." (tm-id-p tm-id "get-types-of-node-content") - (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + (let ((xml-base (get-xml-base node :old-base parent-xml-base))) (let ((attr-type (if (get-ns-attribute node "type") (list (list :topicid (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + xml-base tm-id) :psi (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + xml-base tm-id) :ID nil)) nil)) (content-types @@ -691,17 +694,17 @@ (string= (get-node-name child) "type")) collect (let ((nodeID (get-ns-attribute child "nodeID")) (resource (get-absolute-attribute - child tm-id fn-xml-base "resource")) + child tm-id xml-base "resource")) (UUID (get-ns-attribute child "UUID" :ns-uri *rdf2tm-ns*)) (ID (get-absolute-attribute child tm-id - fn-xml-base "ID"))) + xml-base "ID"))) (if (or nodeID resource UUID) (list :topicid (or nodeID resource UUID) :psi resource :ID ID) (let ((child-xml-base - (get-xml-base child :old-base fn-xml-base))) + (get-xml-base child :old-base xml-base))) (let ((refs (get-node-refs (child-nodes-or-text child :trim t) @@ -712,9 +715,9 @@ (remove-if #'null (append attr-type content-types))))) -(defun get-literals-of-property (property xml-lang) +(defun get-literals-of-property (property parent-xml-lang) "Returns a list of attributes that are treated as literal nodes." - (let ((fn-xml-lang (get-xml-lang property :old-lang xml-lang)) + (let ((xml-lang (get-xml-lang property :old-lang parent-xml-lang)) (attributes nil)) (dom:map-node-map #'(lambda(attr) @@ -737,7 +740,7 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))) ((or (string= attr-ns *xml-ns*) @@ -749,16 +752,16 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))))))) (dom:attributes property)) attributes)) -(defun get-literals-of-node (node xml-lang) +(defun get-literals-of-node (node parent-xml-lang) "Returns alist of attributes that are treated as literal nodes." - (let ((fn-xml-lang (get-xml-lang node :old-lang xml-lang)) + (let ((xml-lang (get-xml-lang node :old-lang parent-xml-lang)) (attributes nil)) (dom:map-node-map #'(lambda(attr) @@ -777,7 +780,7 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))) ((or (string= attr-ns *xml-ns*) @@ -789,19 +792,19 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))))))) (dom:attributes node)) attributes)) -(defun get-super-classes-of-node-content (node tm-id xml-base) +(defun get-super-classes-of-node-content (node tm-id parent-xml-base) "Returns a list of super-classes and IDs." (declare (dom:element node)) (tm-id-p tm-id "get-super-classes-of-node-content") (let ((content (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base))) + (xml-base (get-xml-base node :old-base parent-xml-base))) (when content (loop for property across content when (let ((prop-name (get-node-name property)) @@ -809,13 +812,13 @@ (and (string= prop-name "subClassOf") (string= prop-ns *rdfs-ns*))) collect (let ((prop-xml-base (get-xml-base property - :old-base fn-xml-base))) + :old-base xml-base))) (let ((ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (nodeID (get-ns-attribute property "nodeID")) (resource (get-absolute-attribute property tm-id - fn-xml-base "resource")) + xml-base "resource")) (UUID (get-ns-attribute property "UUID" :ns-uri *rdf2tm-ns*))) (if (or nodeID resource UUID) @@ -830,17 +833,17 @@ :ID ID))))))))) -(defun get-associations-of-node-content (node tm-id xml-base) +(defun get-associations-of-node-content (node tm-id parent-xml-base) "Returns a list of associations with a type, value and ID member." (declare (dom:element node)) (let ((properties (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base))) + (xml-base (get-xml-base node :old-base parent-xml-base))) (loop for property across properties when (let ((prop-name (get-node-name property)) (prop-ns (dom:namespace-uri property)) (prop-content (child-nodes-or-text property)) (resource (get-absolute-attribute property tm-id - fn-xml-base "resource")) + xml-base "resource")) (nodeID (get-ns-attribute property "nodeID")) (type (get-ns-attribute property "type")) (parseType (get-ns-attribute property "parseType")) @@ -858,7 +861,7 @@ (not (and (string= prop-name "subClassOf") (string= prop-ns *rdfs-ns*))))) collect (let ((prop-xml-base (get-xml-base property - :old-base fn-xml-base)) + :old-base xml-base)) (content (child-nodes-or-text property :trim t)) (parseType (get-ns-attribute property "parseType"))) (let ((resource @@ -866,12 +869,12 @@ (= (length content) 0)) *rdf-nil* (get-absolute-attribute property tm-id - fn-xml-base "resource"))) + xml-base "resource"))) (nodeID (get-ns-attribute property "nodeID")) (UUID (get-ns-attribute property "UUID" :ns-uri *rdf2tm-ns*)) (ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (full-name (get-type-of-node-name property))) (if (or nodeID resource UUID) (list :type full-name @@ -889,42 +892,45 @@ (defun make-recursion-from-node (node tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Calls the next function that handles all DOM child elements of the passed element as arcs." (declare (dom:element node)) (let ((content (child-nodes-or-text node :trim t)) (err-pref "From make-recursion-from-node(): ") - (fn-xml-base (get-xml-base node :old-base xml-base)) - (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) + (xml-base (get-xml-base node :old-base parent-xml-base)) + (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) (when (stringp content) (error "~aliteral content not allowed here: ~a" err-pref content)) (loop for arc across content collect (import-arc arc tm-id start-revision :document-id document-id - :xml-base fn-xml-base :xml-lang fn-xml-lang)))) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) (defun make-recursion-from-arc (arc tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Calls the next function that handles the arcs content nodes/arcs." (declare (dom:element arc)) - (let ((fn-xml-base (get-xml-base arc :old-base xml-base)) - (fn-xml-lang (get-xml-lang arc :old-lang xml-lang)) + (let ((xml-base (get-xml-base arc :old-base parent-xml-base)) + (xml-lang (get-xml-lang arc :old-lang parent-xml-lang)) (content (child-nodes-or-text arc)) (parseType (get-ns-attribute arc "parseType"))) - (let ((datatype (get-absolute-attribute arc tm-id xml-base "datatype")) - (type (get-absolute-attribute arc tm-id xml-base "type")) - (resource (get-absolute-attribute arc tm-id xml-base "resource")) + (let ((datatype (get-absolute-attribute arc tm-id + parent-xml-base "datatype")) + (type (get-absolute-attribute arc tm-id parent-xml-base "type")) + (resource (get-absolute-attribute arc tm-id + parent-xml-base "resource")) (nodeID (get-ns-attribute arc "nodeID")) - (literals (get-literals-of-property arc xml-lang))) + (literals (get-literals-of-property arc parent-xml-lang))) (if (and parseType (string= parseType "Collection")) (make-collection arc tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) (if (or datatype resource nodeID (and parseType (string= parseType "Literal")) @@ -938,10 +944,10 @@ (loop for item across content collect (import-arc item tm-id start-revision :document-id document-id - :xml-base fn-xml-base - :xml-lang fn-xml-lang)) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)) (loop for item across content collect (import-node item tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang)))))))) \ No newline at end of file + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))))))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Wed Sep 9 03:42:00 2009 @@ -282,21 +282,21 @@ t) -(defun get-node-refs (nodes tm-id xml-base) +(defun get-node-refs (nodes tm-id parent-xml-base) "Returns a list of node references that can be used as topic IDs." (when (and nodes (> (length nodes) 0)) (loop for node across nodes - collect (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + collect (let ((xml-base (get-xml-base node :old-base parent-xml-base))) (parse-node node) (let ((ID (when (get-ns-attribute node "ID") (absolutize-id (get-ns-attribute node "ID") - fn-xml-base tm-id))) + xml-base tm-id))) (nodeID (get-ns-attribute node "nodeID")) (about (when (get-ns-attribute node "about") (absolutize-value (get-ns-attribute node "about") - fn-xml-base tm-id))) + xml-base tm-id))) (UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*))) (list :topicid (or ID about nodeID UUID) :psi (or ID about))))))) @@ -465,29 +465,28 @@ t) -(defun get-absolute-attribute (elem tm-id xml-base attr-name +(defun get-absolute-attribute (elem tm-id parent-xml-base attr-name &key (ns-uri *rdf-ns*)) "Returns an absolute 'attribute' or nil." (declare (dom:element elem)) (declare (string attr-name)) (tm-id-p tm-id "get-ID") (let ((attr (get-ns-attribute elem attr-name :ns-uri ns-uri)) - (fn-xml-base (get-xml-base elem :old-base xml-base))) + (xml-base (get-xml-base elem :old-base parent-xml-base))) (when attr (if (and (string= ns-uri *rdf-ns*) (string= attr-name "ID")) - (absolutize-id attr fn-xml-base tm-id) - (absolutize-value attr fn-xml-base tm-id))))) + (absolutize-id attr xml-base tm-id) + (absolutize-value attr xml-base tm-id))))) -(defun get-datatype (elem tm-id xml-base) +(defun get-datatype (elem tm-id parent-xml-base) "Returns a datatype value. The default is xml:string." - (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) - (let ((datatype - (get-absolute-attribute elem tm-id fn-xml-base "datatype"))) - (if datatype - datatype - *xml-string*)))) + (let ((datatype + (get-absolute-attribute elem tm-id parent-xml-base "datatype"))) + (if datatype + datatype + *xml-string*))) (defun tm-id-p (tm-id fun-name) @@ -500,14 +499,13 @@ (defun get-types-of-node (elem tm-id &key (parent-xml-base nil)) "Returns a plist of all node's types of the form (:topicid <string> :psi <string> :ID <string>)." - (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) - (remove-if - #'null - (append (unless (string= (get-type-of-node-name elem) - (concatenate 'string *rdf-ns* - "Description")) - (list - (list :topicid (get-type-of-node-name elem) - :psi (get-type-of-node-name elem) - :ID nil))) - (get-types-of-node-content elem tm-id xml-base))))) \ No newline at end of file + (remove-if + #'null + (append (unless (string= (get-type-of-node-name elem) + (concatenate 'string *rdf-ns* + "Description")) + (list + (list :topicid (get-type-of-node-name elem) + :psi (get-type-of-node-name elem) + :ID nil))) + (get-types-of-node-content elem tm-id parent-xml-base)))) \ No newline at end of file

1 0

[isidorus-cvs] r138 - trunk/src/xml/rdf
by Lukas Giessmann 08 Sep '09

08 Sep '09

Author: lgiessmann Date: Tue Sep 8 09:37:26 2009 New Revision: 138 Log: rdf-importer: fixed a bug when importing rdf-isidorus-names without nametypes. Modified: trunk/src/xml/rdf/map_to_tm.lisp Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 09:37:26 2009 @@ -277,8 +277,7 @@ "Maps the passed occurrence-topic to a TM occurrence." (declare (TopicC top name-top)) (declare (integer start-revision)) - (let ((err-pref "From map-isi-name(): ") - (ids (map-isi-identifiers name-top start-revision)) + (let ((ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type name-top start-revision *tm2rdf-nametype-property* @@ -290,8 +289,11 @@ (value-type-topic (get-item-by-psi *tm2rdf-value-property*)) (variant-topics (get-isi-variants name-top start-revision))) - (let ((types (get-players-by-role-type - type-assocs start-revision *rdf2tm-object*)) + (let ((types (let ((fn-types + (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*))) + (when fn-types + (first fn-types)))) (scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value @@ -305,14 +307,11 @@ (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct type-assocs) (map 'list #'d::delete-construct scope-assocs) - (when (/= 1 (length types)) - (error "~aexpect one type topic but found: ~a (~a)" - err-pref (length types) value)) (let ((name (make-construct 'NameC :start-revision start-revision :topic top :charvalue value - :instance-of (first types) + :instance-of types :item-identifiers ids :themes scopes))) (map 'list #'(lambda(variant-top)

1 0

[isidorus-cvs] r137 - trunk/src/unit_tests
by Lukas Giessmann 08 Sep '09

08 Sep '09

Author: lgiessmann Date: Tue Sep 8 06:54:19 2009 New Revision: 137 Log: rdf-importer: added some unit-tests Modified: trunk/src/unit_tests/full_mapping.rdf trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/unit_tests/unittests-constants.lisp Modified: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- trunk/src/unit_tests/full_mapping.rdf (original) +++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 06:54:19 2009 @@ -31,7 +31,7 @@ </rdf:Description> - <rdf:Description rdf:nodeID="id_285"> + <rdf:Description rdf:nodeID="id_283"> <isi:variant rdf:parseType="Resource"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> <isi:scope rdf:resource="http://simpsons/display"/> @@ -121,13 +121,13 @@ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> </rdf:Description> - <rdf:Description> + <rdf:Description rdf:nodeID="id_291"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/> <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-2</isi:itemIdentity> <isi:associationtype rdf:resource="http://simpsons/married"/> <isi:role> - <rdf:Description> + <rdf:Description rdf:nodeID="id_295"> <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/wife"/> @@ -135,7 +135,7 @@ </rdf:Description> </isi:role> <isi:role> - <rdf:Description> + <rdf:Description rdf:nodeID="id_292"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/husband"/> <isi:player rdf:resource="http://simpsons/homer"/> Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Tue Sep 8 06:54:19 2009 @@ -66,7 +66,10 @@ :test-poems-rdf-topics :test-empty-collection :test-collection - :test-xml-base)) + :test-xml-base + :test-full-mapping-marge + :test-full-mapping-homer + :test-full-mapping-association)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -79,6 +82,14 @@ (in-suite rdf-importer-test) +(defun empty-p (top) + (declare (TopicC top)) + (and (not (d:item-identifiers top)) + (not (d:locators top)) + (not (d:names top)) + (not (d:occurrences top)))) + + (test test-get-literals-of-node "Tests the helper function get-literals-of-node." (let ((doc-1 @@ -3060,6 +3071,306 @@ "/test") "http://base-3/test"))))))) + +(test test-full-mapping-marge + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (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)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((firstName (get-item-by-id "http://simpsons/firstName")) + (lastName (get-item-by-id "http://simpsons/lastName")) + (display (get-item-by-id "http://simpsons/display")) + (profession (get-item-by-id "http://simpsons/profession")) + (married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (en (get-item-by-id "http://simpsons/en")) + (type (get-item-by-psi *type-psi*)) + (instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (isi-object (get-item-by-psi *rdf2tm-object*)) + (isi-subject (get-item-by-psi *rdf2tm-subject*)) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true firstName) + (is-true (empty-p firstName)) + (is-true lastName) + (is-true (empty-p lastName)) + (is-true display) + (is-true (empty-p display)) + (is-true profession) + (is-true (empty-p profession)) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true en) + (is-true (empty-p en)) + (is-true type) + (is-true (empty-p type)) + (is-true instance) + (is-true (empty-p instance)) + (is-true type-instance) + (is-true (empty-p type-instance)) + (is-true isi-object) + (is-true (empty-p isi-object)) + (is-true isi-subject) + (is-true (empty-p isi-subject)) + (is-true role-husband) + (is-true role-wife) + (is-true homer) + (is (= (length (d:psis marge)) 2)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/marjorie")) + (d:psis marge))) + (is (= (length (d:names marge)) 2)) + (let ((marge-fn (find-if #'(lambda(x) + (eql (instance-of x) firstName)) + (d:names marge))) + (marge-ln (find-if #'(lambda(x) + (eql (instance-of x) lastName)) + (d:names marge))) + (marge-occ (find-if #'(lambda(x) + (eql (instance-of x) profession)) + (d:occurrences marge)))) + (is-true marge-fn) + (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-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)))))) + + +(test test-full-mapping-homer + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (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)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((firstName (get-item-by-id "http://simpsons/firstName")) + (lastName (get-item-by-id "http://simpsons/lastName")) + (display (get-item-by-id "http://simpsons/display")) + (profession (get-item-by-id "http://simpsons/profession")) + (married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (en (get-item-by-id "http://simpsons/en")) + (type (get-item-by-psi *type-psi*)) + (instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (isi-object (get-item-by-psi *rdf2tm-object*)) + (isi-subject (get-item-by-psi *rdf2tm-subject*)) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true firstName) + (is-true (empty-p firstName)) + (is-true lastName) + (is-true (empty-p lastName)) + (is-true display) + (is-true (empty-p display)) + (is-true profession) + (is-true (empty-p profession)) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true en) + (is-true (empty-p en)) + (is-true type) + (is-true (empty-p type)) + (is-true instance) + (is-true (empty-p instance)) + (is-true type-instance) + (is-true (empty-p type-instance)) + (is-true isi-object) + (is-true (empty-p isi-object)) + (is-true isi-subject) + (is-true (empty-p isi-subject)) + (is-true role-husband) + (is-true role-wife) + (is-true marge) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/homer_simpson")) + (d:psis homer))) + (is (= (length (d:locators homer)) 1)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://some.where/resource")) + (d:locators homer))) + (is (= (length (d:item-identifiers homer)) 1)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/ii/homer")) + (d:item-identifiers homer))) + (is (= (length (d:names homer)) 2)) + (let ((homer-fn (find-if #'(lambda(x) + (eql (instance-of x) firstName)) + (d:names homer))) + (homer-ln (find-if #'(lambda(x) + (eql (instance-of x) lastName)) + (d:names homer))) + (homer-occ (find-if #'(lambda(x) + (eql (instance-of x) profession)) + (d:occurrences homer)))) + (is-true homer-fn) + (is-true homer-ln) + (is (string= (d:charvalue homer-fn) "Homer J.")) + (is (string= (d:charvalue homer-ln) "Simpson")) + (is (= (length (d:variants homer-fn)) 1)) + (is (= (length (d:themes (first (d:variants homer-fn)))) 1)) + (is (eql (first (d:themes (first (d:variants homer-fn)))) display)) + (is (string= (d:charvalue (first (d:variants homer-fn))) "Homer")) + (is (string= (d:datatype (first (d:variants homer-fn))) *xml-string*)) + (is-true homer-occ) + (is (string= (d:charvalue homer-occ) "Safety Inspector")) + (is (string= (d:datatype homer-occ) *xml-string*)) + (is (= (length (d:themes homer-occ)) 1)) + (is (eql (first (d:themes homer-occ)) en)))))) + + +(test test-full-mapping-association + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (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)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (assoc (first (elephant:get-instances-by-class 'd:AssociationC))) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true role-husband) + (is-true role-wife) + (is-true marge) + (is-true homer) + (is (= (length (intersection (list role-husband role-wife) + (d:roles assoc))) + 2)) + (is (eql (d:instance-of assoc) married)) + (is (= (length (d:item-identifiers assoc)) 2)) + (is (= (length + (intersection + (list + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-1") + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-2")) + (d:item-identifiers assoc))) + 2)) + (is (eql (d:instance-of role-husband) husband)) + (is (eql (d:instance-of role-wife) wife)) + (is (eql (d:player role-husband) homer)) + (is (eql (d:player role-wife) marge)) + (is (= (length (d:item-identifiers role-husband)) 1)) + (is (= (length (d:item-identifiers role-wife)) 1)) + (is (string= (d:uri (first (d:item-identifiers role-husband))) + "http://simpsons/role-husband/ii")) + (is (string= (d:uri (first (d:item-identifiers role-wife))) + "http://simpsons/role-wife/ii"))))) + + (defun run-rdf-importer-tests() "Runs all defined tests." (when elephant:*store-controller* @@ -3082,4 +3393,7 @@ (it.bese.fiveam:run! 'test-poems-rdf-topics) (it.bese.fiveam:run! 'test-empty-collection) (it.bese.fiveam:run! 'test-collection) - (it.bese.fiveam:run! 'test-xml-base)) \ No newline at end of file + (it.bese.fiveam:run! 'test-xml-base) + (it.bese.fiveam:run! 'test-full-mapping-marge) + (it.bese.fiveam:run! 'test-full-mapping-homer) + (it.bese.fiveam:run! 'test-full-mapping-association)) \ No newline at end of file Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Tue Sep 8 06:54:19 2009 @@ -30,7 +30,8 @@ :*atom_test.xtm* :*atom-conf.lisp* :*poems_light.rdf* - :*poems_light.xtm*)) + :*poems_light.xtm* + :*full_mapping.rdf*)) (in-package :unittests-constants) @@ -99,3 +100,7 @@ (defparameter *poems_light.xtm* (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light.xtm"))) + +(defparameter *full_mapping.rdf* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "full_mapping.rdf"))) \ No newline at end of file

1 0

[isidorus-cvs] r136 - in trunk/src: . unit_tests xml/rdf
by Lukas Giessmann 08 Sep '09

08 Sep '09

Author: lgiessmann Date: Tue Sep 8 04:51:36 2009 New Revision: 136 Log: rdf-exporter: fixed a bug with missing name-types; rdf-importer: fixed a bug with merging/versioning of blank_nodes --> they get an item-identifier concatenated of a predefined prefix and their nodeID or a UUID Modified: trunk/src/constants.lisp trunk/src/unit_tests/full_mapping.rdf trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Tue Sep 8 04:51:36 2009 @@ -61,7 +61,8 @@ :*tm2rdf-occurrencetype-property* :*tm2rdf-roletype-property* :*tm2rdf-associationtype-property* - :*tm2rdf-player-property*)) + :*tm2rdf-player-property* + :*rdf2tm-blank-node-prefix*)) (in-package :constants) @@ -123,6 +124,8 @@ (defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/")) +(defparameter *rdf2tm-blank-node-prefix* (concatenate 'string *rdf2tm-ns* "blank_node/")) + (defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/") (defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "types/Topic")) Modified: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- trunk/src/unit_tests/full_mapping.rdf (original) +++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 04:51:36 2009 @@ -64,7 +64,7 @@ </isi:variant> </rdf:Description> </isi:name> -   + <isi:name rdf:resource="id_2345"/>  <isi:name> <rdf:Description rdf:nodeID="id_277"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> @@ -102,7 +102,7 @@ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> <isi:role> <rdf:Description rdf:nodeID="id_292"> - <isi:itemIdentity rdf:datatype="">http://simpsons/role-husband/ii</isi:itemIdentity> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-husband/ii</isi:itemIdentity> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/husband"/> <isi:player rdf:resource="http://simpsons/homer"/> @@ -117,15 +117,29 @@ </isi:role> </rdf:Description> + <rdf:Description rdf:nodeID="id_295"> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> + </rdf:Description> + <rdf:Description> - <isi:itemIdentity rdf:datatype="">http://simpsons/maried/ii-2</isi:itemIdentity> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-2</isi:itemIdentity> + <isi:associationtype rdf:resource="http://simpsons/married"/> <isi:role> - <rdf:Description rdf:nodeID="id_295"> - <isi:itemIdentity rdf:datatype="">http://simpsons/role-wife/ii</isi:itemIdentity> + <rdf:Description> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/wife"/> <isi:player rdf:resource="http://simpsons/marge"/> </rdf:Description> </isi:role> + <isi:role> + <rdf:Description> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/husband"/> + <isi:player rdf:resource="http://simpsons/homer"/> + </rdf:Description> + </isi:role> </rdf:Description> -</rdf:RDF> \ No newline at end of file +</rdf:RDF> Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Tue Sep 8 04:51:36 2009 @@ -39,7 +39,7 @@ to be exported, the same mechanism as in xtm-exporter") -(defvar *ns-map* nil) ;; ((:prefix <string> :uri <string>)) +(defvar *ns-map* nil "((:prefix <string> :uri <string>))") (defun rdf-li-or-uri (uri) @@ -297,8 +297,9 @@ (cxml:attribute "rdf:nodeID" (make-object-id construct)) (make-isi-type *tm2rdf-name-type-uri*) (map 'list #'to-rdf-elem (item-identifiers construct)) - (cxml:with-element "isi:nametype" - (make-topic-reference (instance-of construct))) + (when (slot-boundp construct 'instance-of) + (cxml:with-element "isi:nametype" + (make-topic-reference (instance-of construct)))) (scopes-to-rdf-elems construct) (cxml:with-element "isi:value" (cxml:attribute "rdf:datatype" *xml-string*) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Tue Sep 8 04:51:36 2009 @@ -411,28 +411,25 @@ If about or ID is set there will also be created a new PSI." (declare (TopicMapC tm)) (let ((topic-id (or about ID nodeID UUID)) - (psi-uri (or about ID))) + (psi-uri (or about ID)) + (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 and/or xtm-id + ;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))) - ;; (unless (find-if #'(lambda(version) - ;; (= start-revision - ;; (d::start-revision version))) - ;; versions) - ;; (d::add-to-version-history inner-top - ;; :start-revision start-revision) - ;; (add-to-topicmap tm inner-top))))))) - (when (and inner-top - (find-if #'(lambda(x) - (= (d::start-revision x) start-revision)) - (d::versions inner-top))) - inner-top)))) + (when inner-top + (let ((versions (d::versions inner-top))) + (when (find-if #'(lambda(version) + (= start-revision + (d::start-revision version))) + versions) + inner-top)))))) (if top top (elephant:ensure-transaction (:txn-nosync t) @@ -440,7 +437,12 @@ (list (make-instance 'PersistentIdC :uri psi-uri - :start-revision start-revision))))) + :start-revision start-revision)))) + (iis (when ii-uri + (list + (make-instance 'ItemIdentifierC + :uri ii-uri + :start-revision start-revision))))) (handler-case (let ((top (add-to-topicmap tm @@ -448,6 +450,7 @@ 'TopicC :topicid topic-id :psis psis + :item-identifiers iis :xtm-id document-id :start-revision start-revision)))) (format t "t") @@ -463,12 +466,12 @@ (when lang (let ((psi-and-topic-id (concatenate-uri *rdf2tm-scope-prefix* lang))) - (let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id - :revision start-revision))) - (if top - top - (make-topic-stub psi-and-topic-id nil nil nil start-revision - tm :document-id document-id)))))) + ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id +; :revision start-revision))) +; (if top +; top + (make-topic-stub psi-and-topic-id nil nil nil start-revision + tm :document-id document-id)))) (defun make-association (top association tm start-revision Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 04:51:36 2009 @@ -71,13 +71,15 @@ (type-instance (get-item-by-psi *type-instance-psi*)) (type (get-item-by-psi *type-psi*))) (declare (TopicC instance-topic type-topic)) - (let ((assocs (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)))) + (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))))) (map 'list #'(lambda(assoc) (when (find-if #'(lambda(role) (and (eql (instance-of role) type) @@ -86,6 +88,13 @@ (d::delete-construct assoc))) assocs) nil)))) + + +(defun delete-related-associations (top) + "Deletes all associaitons related to the passed topic." + (dolist (assoc-role (player-in-roles top)) + (d::delete-construct (parent assoc-role))) + top) (defun get-isi-roles(assoc-top start-revision) @@ -109,8 +118,6 @@ (declare (TopicC role-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-role(): ") - (role-type-topic (get-item-by-psi *tm2rdf-role-type-uri* - :revision start-revision)) (ids (map-isi-identifiers role-top start-revision)) (type-assocs (get-associations-by-type @@ -133,7 +140,7 @@ (when (= 0 (length role-players)) (error "~aexpect one player but found: ~a" err-pref (length role-players))) - (delete-instance-of-association role-top role-type-topic) + (delete-related-associations role-top) (d::delete-construct role-top) (list :instance-of (first types) :player (first role-players) @@ -175,6 +182,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) (d::delete-construct assoc-top) (with-tm (start-revision document-id tm-id) (add-to-topicmap @@ -234,8 +242,6 @@ (declare (NameC name)) (declare (integer start-revision)) (let ((ids (map-isi-identifiers variant-top start-revision)) - (variant-type-topic (get-item-by-psi *tm2rdf-variant-type-uri* - :revision start-revision)) (scope-assocs (get-associations-by-type variant-top start-revision *tm2rdf-scope-property* @@ -256,7 +262,7 @@ :datatype *xml-string*))))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) - (delete-instance-of-association variant-top variant-type-topic) + (delete-related-associations variant-top) (d::delete-construct variant-top) (make-construct 'VariantC :start-revision start-revision @@ -272,8 +278,6 @@ (declare (TopicC top name-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-name(): ") - (name-type-topic (get-item-by-psi *tm2rdf-name-type-uri* - :revision start-revision)) (ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type @@ -314,7 +318,7 @@ (map 'list #'(lambda(variant-top) (map-isi-variant name variant-top start-revision)) variant-topics) - (delete-instance-of-association name-top name-type-topic) + (delete-related-associations name-top) (d::delete-construct name-top) name))))) @@ -339,8 +343,6 @@ (declare (integer start-revision)) (let ((err-pref "From map-isi-occurrence(): ") (ids (map-isi-identifiers occ-top start-revision)) - (occurrence-type-topic (get-item-by-psi *tm2rdf-occurrence-type-uri* - :revision start-revision)) (type-assocs (get-associations-by-type occ-top start-revision *tm2rdf-occurrencetype-property* @@ -371,7 +373,7 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) - (delete-instance-of-association occ-top occurrence-type-topic) + (delete-related-associations occ-top) (d::delete-construct occ-top) (make-construct 'OccurrenceC :start-revision start-revision Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Tue Sep 8 04:51:36 2009 @@ -53,7 +53,8 @@ *tm2rdf-occurrencetype-property* *tm2rdf-roletype-property* *tm2rdf-player-property* - *tm2rdf-associationtype-property*) + *tm2rdf-associationtype-property* + *rdf2tm-blank-node-prefix*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) @@ -509,4 +510,4 @@ (list :topicid (get-type-of-node-name elem) :psi (get-type-of-node-name elem) :ID nil))) - (get-types-of-node-content elem tm-id xml-base))))) + (get-types-of-node-content elem tm-id xml-base))))) \ No newline at end of file

1 0

[isidorus-cvs] r135 - in trunk/src: . unit_tests xml/rdf
by Lukas Giessmann 07 Sep '09

07 Sep '09

Author: lgiessmann Date: Mon Sep 7 10:43:54 2009 New Revision: 135 Log: rdf-importer: added an RDF test file with exported and mapped TM constructs. Added: trunk/src/unit_tests/full_mapping.rdf Modified: trunk/src/isidorus.asd trunk/src/xml/rdf/map_to_tm.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Mon Sep 7 10:43:54 2009 @@ -110,6 +110,7 @@ (:static-file "poems.rdf") (:static-file "poems_light.rdf") (:static-file "poems_light.xtm") + (:static-file "full_mapping.rdf") (:file "atom-conf") (:file "unittests-constants" :depends-on ("dangling_topicref.xtm" Added: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- (empty file) +++ trunk/src/unit_tests/full_mapping.rdf Mon Sep 7 10:43:54 2009 @@ -0,0 +1,131 @@ +<?xml version="1.0" encoding="UTF-8"?> +<rdf:RDF xmlns:isi="http://isidorus/tm2rdf_mapping/" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#" + xmlns:xml="http://www.w3.org/XML/1998/namespace"> +  + <rdf:Description rdf:about="http://simpsons/marge"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Topic"/> + <isi:name> + <rdf:Description rdf:nodeID="id_283"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/firstName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Marjorie</isi:value> + </rdf:Description> + </isi:name> + <isi:name> + <rdf:Description rdf:nodeID="id_285"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/lastName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Simpson</isi:value> + </rdf:Description> + </isi:name> + <ns5:profession xmlns:ns5="http://simpsons/" rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Housewife</ns5:profession> + <isi:occurrence rdf:nodeID="id_1234"/>  + </rdf:Description> + + <rdf:Description rdf:nodeID="id_1234"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Occurrence"/> + <isi:occurrencetype rdf:resource="http://simpsons/profession"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Housewife</isi:value> + </rdf:Description> + + + <rdf:Description rdf:nodeID="id_285"> + <isi:variant rdf:parseType="Resource"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> + <isi:scope rdf:resource="http://simpsons/display"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Marge</isi:value> + </isi:variant> + </rdf:Description> + + + <rdf:Description rdf:about="http://simpsons/marge"> + <isi:subjectIdentifier rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/marjorie</isi:subjectIdentifier> + </rdf:Description> + +  + <rdf:Description rdf:about="http://simpsons/homer"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Topic"/> + <isi:subjectIdentifier rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/homer_simpson</isi:subjectIdentifier> + <isi:subjectLocator rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://some.where/resource</isi:subjectLocator> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/ii/homer</isi:itemIdentity> + <isi:name> + <rdf:Description rdf:nodeID="id_266"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/firstName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer J.</isi:value> + <isi:variant> + <rdf:Description rdf:nodeID="id_272"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> + <isi:scope rdf:resource="http://simpsons/display"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer</isi:value> + </rdf:Description> + </isi:variant> + </rdf:Description> + </isi:name> +   + <isi:name> + <rdf:Description rdf:nodeID="id_277"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/lastName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Simpson</isi:value> + </rdf:Description> + </isi:name> + <isi:occurrence> + <rdf:Description rdf:nodeID="id_279"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Occurrence"/> + <isi:occurrencetype rdf:resource="http://simpsons/profession"/> + <isi:scope rdf:resource="http://simpsons/en"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Safety Inspector</isi:value> + </rdf:Description> + </isi:occurrence> + </rdf:Description> + + <rdf:Description rdf:about="id_2345"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/firstName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer J.</isi:value> + <isi:variant> + <rdf:Description rdf:nodeID="id_272"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> + <isi:scope rdf:resource="http://simpsons/display"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer</isi:value> + </rdf:Description> + </isi:variant> + </rdf:Description> + +  + <rdf:Description rdf:nodeID="id_291"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/> + <isi:associationtype rdf:resource="http://simpsons/married"/> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> + <isi:role> + <rdf:Description rdf:nodeID="id_292"> + <isi:itemIdentity rdf:datatype="">http://simpsons/role-husband/ii</isi:itemIdentity> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/husband"/> + <isi:player rdf:resource="http://simpsons/homer"/> + </rdf:Description> + </isi:role> + <isi:role> + <rdf:Description rdf:nodeID="id_295"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/wife"/> + <isi:player rdf:resource="http://simpsons/marge"/> + </rdf:Description> + </isi:role> + </rdf:Description> + + <rdf:Description> + <isi:itemIdentity rdf:datatype="">http://simpsons/maried/ii-2</isi:itemIdentity> + <isi:role> + <rdf:Description rdf:nodeID="id_295"> + <isi:itemIdentity rdf:datatype="">http://simpsons/role-wife/ii</isi:itemIdentity> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/wife"/> + <isi:player rdf:resource="http://simpsons/marge"/> + </rdf:Description> + </isi:role> + </rdf:Description> +</rdf:RDF> \ No newline at end of file Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 10:43:54 2009 @@ -302,8 +302,8 @@ (map 'list #'d::delete-construct type-assocs) (map 'list #'d::delete-construct scope-assocs) (when (/= 1 (length types)) - (error "~aexpect one type topic but found: ~a" - err-pref (length types))) + (error "~aexpect one type topic but found: ~a (~a)" + err-pref (length types) value)) (let ((name (make-construct 'NameC :start-revision start-revision :topic top

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs