[isidorus-cvs] r148 - in trunk/src: . model unit_tests xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Nov 24 15:26:43 UTC 2009
Author: lgiessmann
Date: Tue Nov 24 10:26:43 2009
New Revision: 148
Log:
fixed some problems in the "reification"-functions and added a unit-test for the xtm1.0 importer
Modified:
trunk/src/isidorus.asd
trunk/src/model/datamodel.lisp
trunk/src/unit_tests/reification_test.lisp
trunk/src/unit_tests/reification_xtm1.0.xtm
trunk/src/unit_tests/unittests-constants.lisp
trunk/src/xml/xtm/importer_xtm1.0.lisp
trunk/src/xml/xtm/importer_xtm2.0.lisp
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Tue Nov 24 10:26:43 2009
@@ -111,6 +111,7 @@
(:static-file "poems_light.rdf")
(:static-file "poems_light.xtm")
(:static-file "full_mapping.rdf")
+ (:static-file "reification_xtm1.0.xtm")
(:file "atom-conf")
(:file "unittests-constants"
:depends-on ("dangling_topicref.xtm"
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Tue Nov 24 10:26:43 2009
@@ -614,12 +614,12 @@
(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))))
+ (slot-value construct 'reifier))))
(defgeneric (setf reifier) (topic TopicC)
(:method (topic (construct ReifiableConstructC))
- (setf (slot-value construct 'reifier) topic)
- (setf (reified topic) construct)))
+ (setf (slot-value construct 'reifier) topic)))
+; (setf (reified topic) construct)))
(defgeneric item-identifiers (construct &key revision)
(:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
@@ -960,12 +960,12 @@
(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))))
+ (slot-value topic 'reified))))
(defgeneric (setf reified) (reifiable ReifiableConstructC)
(:method (reifiable (topic TopicC))
- (setf (slot-value topic 'reified) reifiable)
- (setf (reifier reifiable) topic)))
+ (setf (slot-value topic 'reified) reifiable)))
+; (setf (reifier reifiable) topic)))
(defgeneric occurrences (topic &key revision)
(:method ((topic TopicC) &key (revision *TM-REVISION*))
@@ -1585,24 +1585,27 @@
;;;;;;;;;;;;;;;;;
;; reification
-(defgeneric add-reifier (construct reifier-uri reifier-must-exist)
- (:method ((construct ReifiableConstructC) reifier-uri reifier-must-exist)
+(defgeneric add-reifier (construct reifier-uri &key xtm-version)
+ (:method ((construct ReifiableConstructC) reifier-uri &key (xtm-version '2.0))
(let ((err "From add-reifier(): "))
- (let ((item-identifier
- (elephant:get-instance-by-value 'ItemIdentifierC 'uri reifier-uri)))
- (unless item-identifier
- (when reifier-must-exist
- (error "~ano item-identifier could be found with the uri ~a"
+ (let ((identifier
+ (elephant:get-instance-by-value (if (eql xtm-version '1.0)
+ 'PersistentIdC
+ 'ItemIdentifierC) 'uri reifier-uri)))
+ (unless identifier
+ (when (eql xtm-version '2.0)
+ (error "~ano identifier could be found with the uri ~a"
err reifier-uri)))
- (when item-identifier
- (let ((reifier-topic (identified-construct item-identifier)))
+ (when identifier
+ (let ((reifier-topic (identified-construct identifier)))
(unless (typep reifier-topic 'TopicC)
- (error "~anitem-identifier ~a must be bound to a topic, but is ~a"
+ (error "~anidentifier ~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 (reifier construct) reifier-topic)
+ (setf (reified reifier-topic) construct))
((and (not (reified reifier-topic))
(reifier construct))
(merge-reifier-topics (reifier construct) reifier-topic))
Modified: trunk/src/unit_tests/reification_test.lisp
==============================================================================
--- trunk/src/unit_tests/reification_test.lisp (original)
+++ trunk/src/unit_tests/reification_test.lisp Tue Nov 24 10:26:43 2009
@@ -17,7 +17,8 @@
(:export
:reification-test
:run-reification-tests
- :test-merge-reifier-topics))
+ :test-merge-reifier-topics
+ :test-xtm1.0-reification))
(in-package :reification-test)
@@ -209,9 +210,72 @@
(test test-xtm1.0-reification
"Tests the reification in the xtm1.0-importer."
-
- )
-
+ (let
+ ((dir "data_base"))
+ (with-fixture initialize-destination-db (dir)
+ (xml-importer:import-xtm *reification_xtm1.0.xtm* dir
+ :tm-id "http://www.isidor.us/unittests/reification-xtm1.0-tests"
+ :xtm-id "reification-xtm"
+ :xtm-format '1.0)
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 12))
+ (is (= (length (elephant:get-instances-by-class 'AssociationC)) 1))
+ (let ((homer
+ (identified-construct
+ (elephant:get-instance-by-value 'PersistentIdC 'uri "http://simpsons.tv/homer")))
+ (married-assoc
+ (first (elephant:get-instances-by-class 'AssociationC))))
+ (let ((homer-occurrence (first (occurrences homer)))
+ (homer-name (first (names homer)))
+ (homer-variant (first (variants (first (names homer)))))
+ (husband-role (find-if #'(lambda(x)
+ (eql (instance-of x)
+ (identified-construct
+ (elephant:get-instance-by-value
+ 'PersistentIdC 'uri "http://simpsons.tv/husband"))))
+ (roles married-assoc)))
+ (reifier-occurrence
+ (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#homer-occurrence")))
+ (reifier-name
+ (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#homer-name")))
+ (reifier-variant
+ (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#homer-name-variant")))
+ (reifier-married-assoc
+ (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#a-married")))
+ (reifier-husband-role
+ (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#married-husband-role"))))
+ (is-true homer)
+ (is-true homer-occurrence)
+ (is-true homer-name)
+ (is-true homer-variant)
+ (is-true married-assoc)
+ (is-true husband-role)
+ (is-true reifier-occurrence)
+ (is-true reifier-name)
+ (is-true reifier-variant)
+ (is-true reifier-married-assoc)
+ (is-true reifier-husband-role)
+ (is (eql (reifier homer-occurrence) reifier-occurrence))
+ (is (eql (reified reifier-occurrence) homer-occurrence))
+ (is (eql (reifier homer-name) reifier-name))
+ (is (eql (reified reifier-name) homer-name))
+ (is (eql (reifier homer-variant) reifier-variant))
+ (is (eql (reified reifier-variant) homer-variant))
+ (is (eql (reifier married-assoc) reifier-married-assoc))
+ (is (eql (reified reifier-married-assoc) married-assoc))
+ (is (eql (reifier husband-role) reifier-husband-role))
+ (is (eql (reified reifier-husband-role) husband-role))
+ (is-true (handler-case
+ (progn (d::delete-construct homer-occurrence)
+ t)
+ (condition () nil)))
+ (is-false (occurrences homer))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12))
+ (is-true (handler-case
+ (progn (d::delete-construct reifier-occurrence)
+ t)
+ (condition () nil)))))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11))
+ (elephant:close-store))))
;;TODO: check xtm2.0 importer
@@ -219,8 +283,10 @@
;;TODO: check xtm1.0 exporter
;;TODO: check xtm2.0 exporter
;;TODO: check fragment exporter
+;;TODO: check merge-reifier-topics (--> versioning)
(defun run-reification-tests ()
(it.bese.fiveam:run! 'test-merge-reifier-topics)
+ (it.bese.fiveam:run! 'test-xtm1.0-refication)
)
\ No newline at end of file
Modified: trunk/src/unit_tests/reification_xtm1.0.xtm
==============================================================================
--- trunk/src/unit_tests/reification_xtm1.0.xtm (original)
+++ trunk/src/unit_tests/reification_xtm1.0.xtm Tue Nov 24 10:26:43 2009
@@ -154,7 +154,7 @@
xmlns:xlink="http://www.w3.org/1999/xlink"
id="married-husband-reifier">
<t:subjectIdentity>
- <t:subjectIndicatorRef xlink:href="#married-husband"/>
+ <t:subjectIndicatorRef xlink:href="#married-husband-role"/>
</t:subjectIdentity>
</t:topic>
</topicMap>
Modified: trunk/src/unit_tests/unittests-constants.lisp
==============================================================================
--- trunk/src/unit_tests/unittests-constants.lisp (original)
+++ trunk/src/unit_tests/unittests-constants.lisp Tue Nov 24 10:26:43 2009
@@ -31,7 +31,8 @@
:*atom-conf.lisp*
:*poems_light.rdf*
:*poems_light.xtm*
- :*full_mapping.rdf*))
+ :*full_mapping.rdf*
+ :*reification_xtm1.0.xtm*))
(in-package :unittests-constants)
@@ -103,4 +104,8 @@
(defparameter *full_mapping.rdf*
(asdf:component-pathname
- (asdf:find-component *unit-tests-component* "full_mapping.rdf")))
\ No newline at end of file
+ (asdf:find-component *unit-tests-component* "full_mapping.rdf")))
+
+(defparameter *reification_xtm1.0.xtm*
+ (asdf:component-pathname
+ (asdf:find-component *unit-tests-component* "reification_xtm1.0.xtm")))
\ No newline at end of file
Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp
==============================================================================
--- trunk/src/xml/xtm/importer_xtm1.0.lisp (original)
+++ trunk/src/xml/xtm/importer_xtm1.0.lisp Tue Nov 24 10:26:43 2009
@@ -18,7 +18,7 @@
(dom:node-value (dom:get-attribute-node reifiable-elem "id")))))
(when (and (stringp reifier-uri)
(> (length reifier-uri) 0))
- (add-reifier reifiable-construct (concatenate 'string "#" reifier-uri) nil))
+ (add-reifier reifiable-construct (concatenate 'string "#" reifier-uri) :xtm-version '1.0))
reifiable-construct))
@@ -430,9 +430,10 @@
(eql (player assoc-role)
(getf list-role :player))
(getf list-role :reifier-uri))
- (add-reifier assoc-role (getf list-role :reifier-uri) nil)))
+ (add-reifier assoc-role (getf list-role :reifier-uri) :xtm-version '1.0)))
roles))
- (roles association))))))
+ (roles association))
+ association))))
(defun set-standard-role-types (roles)
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 Tue Nov 24 10:26:43 2009
@@ -16,7 +16,7 @@
(let ((reifier-uri (get-attribute reifiable-elem "reifier")))
(when (and (stringp reifier-uri)
(> (length reifier-uri) 0))
- (add-reifier reifiable-construct reifier-uri t))
+ (add-reifier reifiable-construct reifier-uri :xtm-version '2.0))
reifiable-construct))
@@ -403,7 +403,7 @@
(eql (player assoc-role)
(getf list-role :player))
(getf list-role :reifier-uri))
- (add-reifier assoc-role (getf list-role :reifier-uri) t)))
+ (add-reifier assoc-role (getf list-role :reifier-uri) :xtm-version '2.0)))
roles))
(roles assoc))
(set-reifier assoc-elem assoc)))))
More information about the Isidorus-cvs
mailing list