[isidorus-cvs] r298 - in branches/new-datamodel/src: model unit_tests xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Sun Jun 13 14:42:34 UTC 2010
Author: lgiessmann
Date: Sun Jun 13 10:42:34 2010
New Revision: 298
Log:
new-datamodel: adpted all unit-test for the xtm-importer (xtm2.0); fixed two bug in make-pointerc; fixed a bug when importing topics, names, occurrences, variants and tm-identifiers; fixed a bug in add-to-tm; fixed a bug when mergin was caused by an item-identifier
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/fixtures.lisp
branches/new-datamodel/src/unit_tests/importer_test.lisp
branches/new-datamodel/src/xml/xtm/importer.lisp
branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Sun Jun 13 10:42:34 2010
@@ -160,7 +160,6 @@
(in-package :datamodel)
-;;TODO: adapt changes.lisp --> changed-p
;;TODO: implement a macro with-merge-constructs, that merges constructs
;; after all operations in the body were called
@@ -1586,8 +1585,9 @@
(= essentially the OID). If xtm-id is explicitly given,
returns one of the topic-ids in that TM
(which must then exist).")
- (:method ((construct TopicC) &optional (xtm-id nil) (revision *TM-REVISION*))
- (declare (type (or null string) xtm-id) (integer revision))
+ (:method ((construct TopicC) &optional (revision *TM-REVISION*) (xtm-id nil))
+ (declare (type (or string null) xtm-id)
+ (type (or integer null) revision))
(if xtm-id
(let ((possible-identifiers
(remove-if-not
@@ -3127,6 +3127,12 @@
:revision revision)))
(when (not (eql id-owner construct))
id-owner))))
+ (when (and construct-to-be-merged
+ (not (eql (type-of construct-to-be-merged)
+ (type-of construct))))
+ (error (make-not-mergable-condition (format nil "From add-item-identifier(): ~a and ~a can't be merged since the identified-constructs are not of the same type"
+ construct construct-to-be-merged)
+ construct construct-to-be-merged)))
(let ((merged-construct construct))
(cond (construct-to-be-merged
(setf merged-construct
@@ -3485,11 +3491,13 @@
(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC))
- (add-association construct 'topics construct-to-add))
+ (add-association construct 'topics construct-to-add)
+ construct-to-add)
(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC))
- (add-association construct 'associations construct-to-add))
+ (add-association construct 'associations construct-to-add)
+ construct-to-add)
(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC))
@@ -3806,11 +3814,12 @@
#'null
(map 'list
#'(lambda(existing-pointer)
- (when (equivalent-construct existing-pointer uri
- xtm-id)
+ (when (equivalent-construct existing-pointer :uri uri
+ :xtm-id xtm-id)
existing-pointer))
(elephant:get-instances-by-value class-symbol 'd::uri uri)))))
- (if existing-pointer existing-pointer
+ (if existing-pointer
+ (first existing-pointer)
(make-instance class-symbol :uri uri :xtm-id xtm-id)))))
(when identified-construct
(cond ((TopicIdentificationC-p class-symbol)
Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/fixtures.lisp (original)
+++ branches/new-datamodel/src/unit_tests/fixtures.lisp Sun Jun 13 10:42:34 2010
@@ -94,14 +94,14 @@
(tear-down-test-db))
(def-fixture initialized-test-db (&optional (xtm *NOTIFICATIONBASE-TM*))
- (let
- ((revision (get-revision)))
+ (let ((revision (get-revision)))
(declare (ignorable revision))
+ (setf *TM-REVISION* revision)
(setf *XTM-TM* xtm)
(set-up-test-db revision)
- (let
- ((tm
- (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm" :revision (d:get-revision))))
+ (let ((tm
+ (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm"
+ :revision revision)))
(declare (ignorable tm))
(&body)
(tear-down-test-db))))
Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/importer_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/importer_test.lisp Sun Jun 13 10:42:34 2010
@@ -22,7 +22,8 @@
xpath-select-location-path)
(:import-from :exceptions
missing-reference-error
- duplicate-identifier-error)
+ duplicate-identifier-error
+ not-mergable-error )
(:export :importer-test
:test-error-detection
:run-importer-tests
@@ -57,19 +58,19 @@
"Test the from-type-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((type-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "occurrence")
- (*xtm2.0-ns* "type")))))
+ (let ((type-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "occurrence")
+ (*xtm2.0-ns* "type"))))
+ (rev-1 *TM-REVISION*))
(loop for type-elem in type-elems do
- (is (typep (from-type-elem type-elem) 'TopicC)))
- (is-false (from-type-elem nil))
+ (is (typep (from-type-elem type-elem rev-1) 'TopicC)))
+ (is-false (from-type-elem nil rev-1))
(let
((t100-occtype
- (from-type-elem (first type-elems))))
+ (from-type-elem (first type-elems) rev-1)))
(format t "occtype: ~a~&" t100-occtype)
(format t "occtype: ~a~&" (psis t100-occtype))
(is
@@ -82,19 +83,19 @@
(declare (optimize (debug 3)))
(with-fixture
initialized-test-db()
- (let
- ((scope-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "name")
- (*xtm2.0-ns* "scope")))))
+ (let ((scope-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "name")
+ (*xtm2.0-ns* "scope"))))
+ (rev-1 *TM-REVISION*))
(loop for scope-elem in scope-elems do
- (is (>= (length (from-scope-elem scope-elem)) 1)))
- (is-false (from-scope-elem nil))
+ (is (>= (length (from-scope-elem scope-elem rev-1)) 1)))
+ (is-false (from-scope-elem nil rev-1))
(let
((t101-themes
- (from-scope-elem (first scope-elems))))
+ (from-scope-elem (first scope-elems) rev-1)))
(is (= 1 (length t101-themes)))
(is
(string=
@@ -105,54 +106,51 @@
"Test the from-name-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((name-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "name"))))
- (top (get-item-by-id "t1"))) ;an arbitrary topic
+ (let ((name-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "name"))))
+ (top (get-item-by-id "t1")) ;an arbitrary topic
+ (rev-1 *TM-REVISION*))
(loop for name-elem in name-elems do
- (is (typep (from-name-elem name-elem top revision) 'NameC)))
+ (is (typep (from-name-elem name-elem top rev-1) 'NameC)))
(let
- ((t1-name (from-name-elem (first name-elems) top revision))
- (t1-name-copy (from-name-elem (first name-elems) top revision))
- (t101-longname (from-name-elem (nth 27 name-elems) top revision)))
+ ((t1-name (from-name-elem (first name-elems) top rev-1))
+ (t1-name-copy (from-name-elem (first name-elems) top rev-1))
+ (t101-longname (from-name-elem (nth 27 name-elems) top rev-1)))
(is (string= (charvalue t1-name) "Topic Type"))
- (is (string=
- (charvalue t101-longname)
- "ISO/IEC 13250:2002: Topic Maps"))
- (is (= 1 (length (item-identifiers t101-longname))))
-
- (is (string=
- (uri (first (psis (instance-of t101-longname))))
- "http://psi.egovpt.org/types/long-name"))
- (is (themes t101-longname))
+ (is (string= (charvalue t101-longname)
+ "ISO/IEC 13250:2002: Topic Maps"))
+ (is (= 1 (length (item-identifiers t101-longname :revision rev-1))))
+ (is (string= (uri (first (psis (instance-of t101-longname))))
+ "http://psi.egovpt.org/types/long-name"))
+ (is (themes t101-longname :revision rev-1))
(is (string=
- (topic-id (first (themes t101-longname)) *TEST-TM*)
+ (topic-id (first (themes t101-longname :revision rev-1))
+ rev-1 *TEST-TM*)
"t50a"))
- (is (eq t1-name t1-name-copy)) ;must be merged
- ))))
+ (is (eq t1-name t1-name-copy)))))) ;must be merged
+
(test test-from-occurrence-elem
"Test the form-occurrence-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((occ-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")
- (*xtm2.0-ns* "occurrence"))))
- (top (get-item-by-id "t1"))) ;an abritrary topic
-
+ (let ((occ-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic")
+ (*xtm2.0-ns* "occurrence"))))
+ (top (get-item-by-id "t1")) ;an abritrary topic
+ (rev-1 *TM-REVISION*))
(loop for occ-elem in occ-elems do
- (is (typep (from-occurrence-elem occ-elem top revision)
- 'OccurrenceC)))
+ (is (typep (from-occurrence-elem occ-elem top rev-1)
+ 'OccurrenceC)))
(is (= 1 (length (elephant:get-instances-by-value
- 'ItemIdentifierC
- 'uri
- "http://psi.egovpt.org/itemIdentifiers#t100_o1"))))
+ 'ItemIdentifierC
+ 'uri
+ "http://psi.egovpt.org/itemIdentifiers#t100_o1"))))
(let
((t100-occ1
(identified-construct
@@ -166,9 +164,9 @@
'ItemIdentifierC
'uri
"http://psi.egovpt.org/itemIdentifiers#t100_o2"))))
- (is (= 1 (length (item-identifiers t100-occ1))));just to double-check
+ (is (= 1 (length (item-identifiers t100-occ1 :revision rev-1)))) ;just to double-check
(is (string=
- (uri (first (item-identifiers t100-occ1)))
+ (uri (first (item-identifiers t100-occ1 :revision rev-1)))
"http://psi.egovpt.org/itemIdentifiers#t100_o1"))
(is (string= (charvalue t100-occ1) "http://www.budabe.de/"))
(is (string= (datatype t100-occ1) "http://www.w3.org/2001/XMLSchema#anyURI"))
@@ -179,40 +177,39 @@
"Test the merge-topic-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((topic-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")))))
-
+ (let ((topic-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic"))))
+ (rev-1 *TM-REVISION*))
(loop for topic-elem in topic-elems do
(is (typep
- (merge-topic-elem topic-elem revision :tm fixtures::tm)
+ (merge-topic-elem topic-elem rev-1 :tm fixtures::tm)
'TopicC)))
(let
((top-t1 (merge-topic-elem (first topic-elems)
- revision :tm fixtures::tm))
+ rev-1 :tm fixtures::tm))
(top-t57 (get-item-by-id "t57"))
(top-t101 (get-item-by-id "t101"))
(top-t301 (get-item-by-id "t301"))
(top-t301a (get-item-by-id "t301a"))
;one of the core PSIs
(top-sup-sub (get-item-by-id "supertype-subtype" :xtm-id "core.xtm")))
- (is (= (internal-id top-t301)
- (internal-id top-t301a)))
- (is (= (length (occurrences top-t1)) 0))
- (is (= (length (occurrences top-t101)) 4))
- (is (= (length (names top-t57)) 1))
- (is (string= (uri (first (item-identifiers top-t57)))
+ (is (= (elephant::oid top-t301) (elephant::oid top-t301a)))
+ (is-true top-t301a)
+ (is (= (length (occurrences top-t1 :revision rev-1)) 0))
+ (is (= (length (occurrences top-t101 :revision rev-1)) 4))
+ (is (= (length (names top-t57 :revision rev-1)) 1))
+ (is (string= (uri (first (item-identifiers top-t57 :revision rev-1)))
"http://psi.egovpt.org/itemIdentifiers#t57"))
- (is (= 2 (length (names top-t101))))
- (is (= 2 (length (names top-t301)))) ;after merge
- (is-true (item-identifiers (first (names top-t301)))) ;after merge
- (is (= 2 (length (psis top-t301)))) ;after merge
- (is (= 3 (length (occurrences top-t301)))) ;after merge
+ (is (= 2 (length (names top-t101 :revision rev-1))))
+ (is (= 2 (length (names top-t301 :revision rev-1)))) ;after merge
+ (is-true (item-identifiers (first (names top-t301 :revision rev-1))
+ :revision rev-1)) ;after merge
+ (is (= 2 (length (psis top-t301 :revision rev-1)))) ;after merge
+ (is (= 3 (length (occurrences top-t301 :revision rev-1)))) ;after merge
(is (string= "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype"
- (uri (first (psis top-sup-sub)))))))
-
+ (uri (first (psis top-sup-sub :revision rev-1)))))))
;34 topics in 35 topic elements in notificationbase.xtm and 13
;core topics
(is (= (+ 34 13) (length (elephant:get-instances-by-class 'TopicC))))))
@@ -226,7 +223,8 @@
(xpath-select-location-path
*XTM-TM*
'((*xtm2.0-ns* "association")
- (*xtm2.0-ns* "role")))))
+ (*xtm2.0-ns* "role"))))
+ (rev-1 *TM-REVISION*))
(loop for role-elem in role-elems do
(is (typep (from-role-elem role-elem revision) 'list)))
(let
@@ -234,43 +232,40 @@
(from-role-elem (nth 11 role-elems) revision)))
(is (string= "t101"
(topic-id
- (getf 12th-role :player) *TEST-TM*)))
+ (getf 12th-role :player) rev-1 *TEST-TM*)))
(is (string= "t62"
(topic-id
- (getf 12th-role :instance-of) *TEST-TM*)))))))
+ (getf 12th-role :instance-of) rev-1 *TEST-TM*)))))))
+
(test test-from-association-elem
"Test the form-association-elem function of the importer"
(with-fixture
initialized-test-db()
- (let
- ((assoc-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "association")))))
+ (let ((assoc-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "association"))))
+ (rev-1 *TM-REVISION*))
(loop for assoc-elem in assoc-elems do
(is
- (typep (from-association-elem assoc-elem revision :tm fixtures::tm)
+ (typep (from-association-elem assoc-elem rev-1 :tm fixtures::tm)
'AssociationC)))
- ;(trace datamodel:item-identifiers datamodel::filter-slot-value-by-revision)
- (let
- ((6th-assoc
- (sixth (elephant:get-instances-by-class 'AssociationC)))
- (last-assoc
- (seventh (elephant:get-instances-by-class 'AssociationC))))
- (is (= 2 (length (roles last-assoc))))
- (is (= 1 (length (item-identifiers last-assoc))))
+ (let ((6th-assoc
+ (sixth (elephant:get-instances-by-class 'AssociationC)))
+ (last-assoc
+ (seventh (elephant:get-instances-by-class 'AssociationC))))
+ (is (= 2 (length (roles last-assoc :revision rev-1))))
+ (is (= 1 (length (item-identifiers last-assoc :revision rev-1))))
(is (string= "t300"
- (topic-id (player (first (roles 6th-assoc))) *TEST-TM*)))
+ (topic-id (player (first (roles 6th-assoc :revision rev-1))
+ :revision rev-1) rev-1 *TEST-TM*)))
(is (string= "t63"
- (topic-id (instance-of (first (roles 6th-assoc)))
- *TEST-TM*)))
+ (topic-id (instance-of (first (roles 6th-assoc :revision rev-1))
+ :revision rev-1) rev-1 *TEST-TM*)))
(is (string= "t301"
- (topic-id (player (first (roles last-assoc)))
- *TEST-TM*))))
- ;(untrace datamodel:item-identifiers datamodel::filter-slot-value-by-revision))
- )
- ;(map 'list (lambda (a) (format t "~a" (exporter:to-string a))) (elephant:get-instances-by-class 'AssociationC))
+ (topic-id (player (first (roles last-assoc :revision rev-1))
+ :revision rev-1) rev-1 *TEST-TM*)))))
(is (= 7
(length (elephant:get-instances-by-class 'AssociationC))))))
@@ -280,60 +275,56 @@
(declare (optimize (debug 3)))
(with-fixture
initialized-test-db()
- (let
- ((topic-elems
- (xpath-select-location-path
- *XTM-TM*
- '((*xtm2.0-ns* "topic")))))
+ (let ((topic-elems
+ (xpath-select-location-path
+ *XTM-TM*
+ '((*xtm2.0-ns* "topic"))))
+ (rev-1 *TM-REVISION*))
(loop for topic-elem in topic-elems do
- (let
- (
- ;this already implicitly creates the instanceOf
- ;associations as needed
- (topic (merge-topic-elem topic-elem revision :tm fixtures::tm)))
- ;(format t "instanceof-topicrefs: ~a~&" instanceof-topicrefs)
- (dolist (io-role
- (elephant:get-instances-by-value
- 'RoleC
- 'player topic))
- (let
- ((io-assoc (parent io-role)))
- ;(format t "(io-topicref: ~a, topic: ~a)~&" io-topicref topic)
- (is
- (typep io-assoc
- 'AssociationC))
- (is (string= (topic-id topic)
- (topic-id (player (second (roles io-assoc))))))))))
-
- (let*
- ((t101-top (get-item-by-id "t101"))
+ (let (;this already implicitly creates the instanceOf
+ ;associations as needed
+ (topic (merge-topic-elem topic-elem rev-1 :tm fixtures::tm)))
+ (dolist (io-role (map 'list #'d::parent-construct
+ (d::slot-p topic 'd::player-in-roles)))
+ (let ((io-assoc (parent io-role :revision rev-1)))
+ (is (typep io-assoc 'AssociationC))
+ (is (string= (topic-id topic rev-1)
+ (topic-id (player (second
+ (roles io-assoc :revision rev-1))
+ :revision rev-1) rev-1)))))))
+ (let* ((t101-top (get-item-by-id "t101" :revision rev-1))
;get all the roles t101 is involved in
- (roles-101 (elephant:get-instances-by-value 'RoleC 'player t101-top))
+ (roles-101 (map 'list #'d::parent-construct
+ (d::slot-p t101-top 'd::player-in-roles)))
;and filter those whose roletype is "instance"
;(returning, of course, a list)
-
;TODO: what we'd really need
;is a filter that works
;directly on the indices
;rather than instantiating
;many unnecessary role objects
- (role-101 (remove-if-not
- (lambda (role)
- (string= (uri (first (psis (instance-of role))))
- "http://psi.topicmaps.org/iso13250/model/instance")) roles-101)))
+ (role-101 (remove-if-not
+ (lambda (role)
+ (string= (uri (first (psis
+ (instance-of role :revision rev-1)
+ :revision rev-1)))
+ "http://psi.topicmaps.org/iso13250/model/instance"))
+ roles-101)))
;Topic t101 (= Topic Maps 2002
;standard) is subclass of
;topic t3a (semantic standard)
-
(is-true t101-top)
(is (= 1 (length role-101)))
- ;(is (= 1 (length (d::versions role-101))))
(is (string= "t3a"
- (topic-id (player (first (roles (parent (first role-101))))) *TEST-TM*)))
+ (topic-id (player (first (roles (parent (first role-101))
+ :revision rev-1))
+ :revision rev-1)
+ rev-1 *TEST-TM*)))
(is (string= "type-instance"
(topic-id (instance-of
- (parent (first role-101))) "core.xtm")))
- ))))
+ (parent (first role-101) :revision rev-1))
+ rev-1 "core.xtm")))))))
+
(test test-error-detection
"Test for the detection of common errors such as dangling
@@ -356,7 +347,7 @@
(importer xtm-dom :xtm-id "missing-reference-error-2"
:tm-id "http://www.isidor.us/unittests/baretests"))))
(with-fixture bare-test-db()
- (signals duplicate-identifier-error
+ (signals not-mergable-error
(let
((xtm-dom
(dom:document-element
@@ -373,45 +364,50 @@
(xml-importer:setup-repository *t100.xtm* dir :xtm-id *TEST-TM*
:tm-id "http://www.isidor.us/unittests/topic-t100")
(elephant:open-store (xml-importer:get-store-spec dir))
-
(is (= 25 (length (elephant:get-instances-by-class 'TopicC)))) ;; are all topics in the db +std topics
- (is-true (get-item-by-id "t100")) ;; main topic
- (is-true (get-item-by-id "t3a")) ;; instanceOf
- (is-true (get-item-by-id "t50a")) ;; scope
- (is-true (get-item-by-id "t51")) ;; occurrence/type
- (is-true (get-item-by-id "t52")) ;; occurrence/resourceRef
- (is-true (get-item-by-id "t53")) ;; occurrence/type
- (is-true (get-item-by-id "t54")) ;; occurrence/type
- (is-true (get-item-by-id "t55")) ;; occurrence/type
- (let ((t100 (get-item-by-id "t100")))
+ (is-true (get-item-by-id "t100" :revision 0)) ;; main topic
+ (is-true (get-item-by-id "t3a" :revision 0)) ;; instanceOf
+ (is-true (get-item-by-id "t50a" :revision 0)) ;; scope
+ (is-true (get-item-by-id "t51" :revision 0)) ;; occurrence/type
+ (is-true (get-item-by-id "t52" :revision 0)) ;; occurrence/resourceRef
+ (is-true (get-item-by-id "t53" :revision 0)) ;; occurrence/type
+ (is-true (get-item-by-id "t54" :revision 0)) ;; occurrence/type
+ (is-true (get-item-by-id "t55" :revision 0)) ;; occurrence/type
+ (let ((t100 (get-item-by-id "t100" :revision 0)))
;; checks instanceOf
- (is (= 1 (length (player-in-roles t100))))
- (let*
- ((role-t100 (first (player-in-roles t100)))
- (assoc (parent role-t100))
- (role-t3a (first (roles assoc))))
- (is (= 1 (length (psis (instance-of role-t100)))))
- (is (string= (uri (first (psis (instance-of role-t100)))) "http://psi.topicmaps.org/iso13250/model/instance"))
- (is (= 1 (length (psis (instance-of role-t3a)))))
- (is (string= (uri (first (psis (instance-of role-t3a)))) "http://psi.topicmaps.org/iso13250/model/type")))
-
+ (is (= 1 (length (player-in-roles t100 :revision 0))))
+ (let* ((role-t100 (first (player-in-roles t100 :revision 0)))
+ (assoc (parent role-t100 :revision 0))
+ (role-t3a (first (roles assoc :revision 0))))
+ (is (= 1 (length (psis (instance-of role-t100 :revision 0) :revision 0))))
+ (is (string= (uri (first (psis (instance-of role-t100 :revision 0)
+ :revision 0)))
+ "http://psi.topicmaps.org/iso13250/model/instance"))
+ (is (= 1 (length (psis (instance-of role-t3a :revision 0) :revision 0))))
+ (is (string= (uri (first (psis (instance-of role-t3a :revision 0)
+ :revision 0)))
+ "http://psi.topicmaps.org/iso13250/model/type")))
;; checks subjectIdentifier
- (is (= 1 (length (psis t100))))
+ (is (= 1 (length (psis t100 :revision 0))))
(is (string= "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata"
- (uri (first (psis t100)))))
- (is (equal (identified-construct (first (psis t100))) t100)) ;;other association part
-
+ (uri (first (psis t100 :revision 0)))))
+ (is (equal (identified-construct (first (psis t100 :revision 0))
+ :revision 0) t100)) ;;other association part
;; checks names
- (is (= 2 (length (names t100))))
- (loop for item in (names t100)
+ (is (= 2 (length (names t100 :revision 0))))
+ (loop for item in (names t100 :revision 0)
do (is (or (string= (charvalue item) "ISO 19115")
(and (string= (charvalue item) "ISO 19115:2003 Geographic Information - Metadata")
- (= (length (themes item)) 1)
- (= (length (psis (first (themes item)))))
- (string= (uri (first (psis (first (themes item))))) "http://psi.egovpt.org/types/long-name")))))
- (is-true (used-as-theme (get-item-by-id "t50a"))) ;checks the other part of the association -> fails
-
+ (= (length (themes item :revision 0)) 1)
+ (= (length (psis (first (themes item :revision 0))
+ :revision 0)))
+ (string= (uri (first (psis (first (themes item :revision 0))
+ :revision 0)))
+ "http://psi.egovpt.org/types/long-name")))))
+ (is-true (used-as-theme (get-item-by-id "t50a" :revision 0)
+ :revision 0)) ;checks the other part of the association -> fails
;; checks occurrences
+ (setf *TM-REVISION* 0)
(is (= 4 (length (occurrences (get-item-by-id "t100")))))
(loop for item in (occurrences t100)
;;(elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item)
@@ -433,12 +429,7 @@
when (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item)
do (progn
(is (string= (charvalue item) "http://www.editeur.org/standards/ISO19115.pdf"))
- (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links")))
- when (and (not (elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item))
- (not (elephant:associatedp (get-item-by-id "t53") 'datamodel::used-as-type item))
- (not (elephant:associatedp (get-item-by-id "t54") 'datamodel::used-as-type item))
- (not (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item)))
- do (is-true nil))))))
+ (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links"))))))))
(test test-setup-repository-xtm1.0
@@ -450,7 +441,7 @@
*sample_objects.xtm* dir
:tm-id "http://www.isidor.us/unittests/xtm1.0-tests"
:xtm-id *TEST-TM* :xtm-format '1.0)
-
+ (setf *TM-REVISION* 0)
(elephant:open-store (xml-importer:get-store-spec dir))
(is (= 36 (length (elephant:get-instances-by-class 'TopicC)))) ;13 + (23 core topics)
(is (= 13 (length (elephant:get-instances-by-class 'AssociationC)))) ;2 + (11 instanceOf)
@@ -507,14 +498,13 @@
do (is-true (format t "bad role found in association: ~A" (topic-identifiers (player role)))))))))
-
(test test-variants
(let
((dir "data_base"))
(with-fixture initialize-destination-db (dir)
(xml-importer:setup-repository
*notificationbase.xtm* dir :xtm-id *TEST-TM*)
-
+ (setf *TM-REVISION* 0)
(elephant:open-store (xml-importer:get-store-spec dir))
(let ((variants (elephant:get-instances-by-class 'VariantC)))
(is (= (length variants) 4))
@@ -523,7 +513,7 @@
(d-type (datatype variant))
(string-type "http://www.w3.org/2001/XMLSchema#string")
(itemIdentities (map 'list #'uri (item-identifiers variant)))
- (parent-name-value (charvalue (name variant)))
+ (parent-name-value (charvalue (parent variant)))
(scopes (map 'list #'uri
(map 'list #'(lambda(x)
(first (psis x))) ;these topics have only one psi
@@ -534,8 +524,8 @@
(cond
((string= resourceData "Long-Version")
(is (string= parent-name-value "long version of a name"))
- (is (= (length (variants (name variant))) 1))
- (is (eql variant (first (variants (name variant)))))
+ (is (= (length (variants (parent variant))) 1))
+ (is (eql variant (first (variants (parent variant)))))
(check-for-duplicate-identifiers variant)
(is-false itemIdentities)
(is (= (length scopes) 1))
@@ -543,9 +533,9 @@
(is (string= d-type string-type)))
((string= resourceData "Geographic Information - Metadata")
(is (string= parent-name-value "ISO 19115"))
- (is (= (length (variants (name variant))) 2))
- (is (or (eql variant (first (variants (name variant))))
- (eql variant (second (variants (name variant))))))
+ (is (= (length (variants (parent variant))) 2))
+ (is (or (eql variant (first (variants (parent variant))))
+ (eql variant (second (variants (parent variant))))))
(check-for-duplicate-identifiers variant)
(is (= (length scopes) 1))
(is (string= (first scopes) display-psi))
@@ -561,8 +551,8 @@
(is (string= d-type string-type)))
((string= resourceData "ISO/IEC-13250:2002")
(is (string= parent-name-value "ISO/IEC 13250:2002: Topic Maps"))
- (is (= (length (variants (name variant))) 1))
- (is (eql variant (first (variants (name variant)))))
+ (is (= (length (variants (parent variant))) 1))
+ (is (eql variant (first (variants (parent variant)))))
(check-for-duplicate-identifiers variant)
(check-for-duplicate-identifiers variant)
(is (= (length scopes) 2))
@@ -654,7 +644,7 @@
'("http://www.isidor.us/unittests/testtm"
"http://www.topicmaps.org/xtm/1.0/core.xtm")
(mapcan (lambda (tm)
- (mapcar #'uri (item-identifiers tm)))
+ (mapcar #'uri (item-identifiers tm :revision 0)))
tms) :test #'string=)))))
Modified: branches/new-datamodel/src/xml/xtm/importer.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/importer.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/importer.lisp Sun Jun 13 10:42:34 2010
@@ -196,5 +196,9 @@
:themes nil
:start-revision start-revision
:instance-of associationtype
- :roles (list (list :instance-of roletype1 :player player1)
- (list :instance-of roletype2 :player player2-obj))))))
+ :roles (list (list :start-revision start-revision
+ :instance-of roletype1
+ :player player1)
+ (list :start-revision start-revision
+ :instance-of roletype2
+ :player player2-obj))))))
Modified: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp
==============================================================================
--- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original)
+++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Sun Jun 13 10:42:34 2010
@@ -34,7 +34,7 @@
(declare (dom:element elem))
(declare (integer start-revision))
(let
- ((id (make-instance classsymbol
+ ((id (make-construct classsymbol
:uri (get-attribute elem "href")
:start-revision start-revision)))
id))
@@ -130,7 +130,7 @@
(error "A name must have exactly one namevalue"))
(let ((name (make-construct 'NameC
:start-revision start-revision
- :topic top
+ :parent top
:charvalue namevalue
:instance-of instance-of
:item-identifiers item-identifiers
@@ -200,7 +200,7 @@
:charvalue (getf variant-value :data)
:datatype (getf variant-value :type)
:reifier reifier-topic
- :name name)))
+ :parent name)))
(defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*))
@@ -226,7 +226,7 @@
(error "OccurrenceC: one of resourceRef and resourceData must be set"))
(make-construct 'OccurrenceC
:start-revision start-revision
- :topic top
+ :parent top
:themes themes
:item-identifiers item-identifiers
:instance-of instance-of
@@ -252,13 +252,17 @@
(subjectidentifiers
(make-identifiers 'PersistentIdC topic-elem "subjectIdentifier" start-revision))
(subjectlocators
- (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision)))
+ (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision))
+ (topic-ids (when (get-attribute topic-elem "id")
+ (list (make-construct 'TopicIdentificationC
+ :uri (get-attribute topic-elem "id")
+ :xtm-id xtm-id)))))
(make-construct 'TopicC
:start-revision start-revision
:item-identifiers itemidentifiers
:locators subjectlocators
:psis subjectidentifiers
- :topicid (get-attribute topic-elem "id")
+ :topic-identifiers topic-ids
:xtm-id xtm-id))))
@@ -283,7 +287,8 @@
'((*xtm2.0-ns* "instanceOf")
(*xtm2.0-ns* "topicRef"))))))
(unless top
- (error "topic ~a could not be found" (get-attribute topic-elem "id")))
+ (error "topic ~a could not be found (xtm-id: ~a, revision: ~a)"
+ (get-attribute topic-elem "id") xtm-id start-revision))
(map 'list
(lambda
(name-elem)
@@ -335,7 +340,8 @@
role-elem
*xtm2.0-ns*
"topicRef"))))
- (list :reifier reifier-topic
+ (list :start-revision start-revision
+ :reifier reifier-topic
:instance-of instance-of
:player player
:item-identifiers item-identifiers))))
More information about the Isidorus-cvs
mailing list