[isidorus-cvs] r457 - in trunk/src: json/JTM unit_tests xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Sun May 8 16:54:00 UTC 2011
Author: lgiessmann
Date: Sun May 8 12:53:59 2011
New Revision: 457
Log:
JTM: added a unit-test for the function make-instance-of-association => if a new instance-of-association is created, all topic-types are added to the parent-topicmaps
Modified:
trunk/src/json/JTM/jtm_importer.lisp
trunk/src/unit_tests/jtm_test.lisp
trunk/src/xml/xtm/importer.lisp
Modified: trunk/src/json/JTM/jtm_importer.lisp
==============================================================================
--- trunk/src/json/JTM/jtm_importer.lisp (original)
+++ trunk/src/json/JTM/jtm_importer.lisp Sun May 8 12:53:59 2011
@@ -77,9 +77,16 @@
(declare (TopicC instance-top type-top)
(List parents)
(Integer revision))
+ (unless parents
+ (error (make-condition 'JTM-error :message (format nil "From make-instance-of-association(): parents must contain at least one TopicMapC object, but is nil"))))
(let ((t-top (get-item-by-psi *type-psi* :revision revision))
(i-top (get-item-by-psi *instance-psi* :revision revision))
(ti-top (get-item-by-psi *type-instance-psi* :revision revision)))
+ (unless (and i-top t-top ti-top)
+ (let ((missing-topic (cond ((not t-top) *type-psi*)
+ ((not i-top) *instance-psi*)
+ (t *type-instance-psi*))))
+ (error (make-condition 'missing-reference-error :message (format nil "From make-instance-of-association(): the core topics ~a, ~a, and ~a are necessary, but ~a cannot be found" *type-psi* *instance-psi* *type-instance-psi* missing-topic) :reference missing-topic))))
(let ((assoc (make-construct 'AssociationC :start-revision revision
:instance-of ti-top
:roles (list (list :start-revision revision
@@ -89,6 +96,9 @@
:player type-top
:instance-of t-top)))))
(dolist (tm parents)
+ (add-to-tm tm i-top)
+ (add-to-tm tm t-top)
+ (add-to-tm tm ti-top)
(add-to-tm tm assoc))
assoc)))
Modified: trunk/src/unit_tests/jtm_test.lisp
==============================================================================
--- trunk/src/unit_tests/jtm_test.lisp (original)
+++ trunk/src/unit_tests/jtm_test.lisp Sun May 8 12:53:59 2011
@@ -39,7 +39,8 @@
:test-import-identifiers
:test-import-variants
:test-import-occurrences
- :test-import-names))
+ :test-import-names
+ :test-make-instance-of-association))
(in-package :jtm-test)
@@ -1634,10 +1635,86 @@
#'jtm::import-name-from-jtm-list :revision 100)))))
+
+(test test-make-instance-of-association
+ "Tests the function make-instance-of-association."
+ (with-fixture with-empty-db ("data_base")
+ (let* ((tt (make-construct 'TopicC :start-revision 100
+ :psis
+ (list (make-construct 'PersistentIdC
+ :uri *type-psi*))))
+ (it (make-construct 'TopicC :start-revision 100
+ :psis
+ (list (make-construct 'PersistentIdC
+ :uri *instance-psi*))))
+ (tit (make-construct 'TopicC :start-revision 100
+ :psis
+ (list (make-construct 'PersistentIdC
+ :uri *type-instance-psi*))))
+ (top-1 (make-construct
+ 'TopicC :start-revision 100
+ :psis
+ (list (make-construct 'PersistentIdC
+ :uri "http://some.where/psi-1"))))
+ (top-2 (make-construct
+ 'TopicC :start-revision 100
+ :locators
+ (list (make-construct 'SubjectLocatorC
+ :uri "http://some.where/sl-1"))))
+ (top-3 (make-construct
+ 'TopicC :start-revision 100
+ :item-identifiers
+ (list (make-construct 'ItemIdentifierC
+ :uri "http://some.where/ii-1"))))
+ (tm (make-construct
+ 'TopicMapC :start-revision 100
+ :item-identifiers
+ (list (make-construct 'ItemIdentifierC
+ :uri "http://some.where/tm-ii")))))
+ (jtm::make-instance-of-association top-1 top-2 (list tm) :revision 100)
+ (is (= (length (player-in-roles top-1 :revision 0)) 1))
+ (is (eql (instance-of (first (player-in-roles top-1 :revision 0)) :revision 0)
+ it))
+ (let ((assoc (parent (first (player-in-roles top-1 :revision 0)) :revision 0)))
+ (is-true assoc)
+ (is (= (length (roles assoc :revision 0)) 2))
+ (is (eql (instance-of assoc :revision 0) tit))
+ (is-true (find tm (in-topicmaps assoc :revision 0)))
+ (is-true (find-if #'(lambda(role)
+ (and (eql (instance-of role :revision 0) tt)
+ (eql (player role :revision 0) top-2)))
+ (roles assoc :revision 0))))
+ (is (= (length (player-in-roles top-2 :revision 0)) 1))
+ (is-true (find tm (in-topicmaps tt :revision 0)))
+ (is-false (find tm (in-topicmaps tt :revision 50)))
+ (is-true (find tm (in-topicmaps it :revision 0)))
+ (is-true (find tm (in-topicmaps tit :revision 0)))
+ (jtm::make-instance-of-association top-2 top-3 (list tm) :revision 100)
+ (is (= (length (player-in-roles top-2 :revision 0)) 2))
+ (is (= (length (player-in-roles top-3 :revision 0)) 1))
+ (is (eql (instance-of (first (player-in-roles top-3 :revision 0)) :revision 0)
+ tt))
+ (let ((assoc (parent (first (player-in-roles top-3 :revision 0)) :revision 0)))
+ (is-true assoc)
+ (is (= (length (roles assoc :revision 0)) 2))
+ (is (eql (instance-of assoc :revision 0) tit))
+ (is-true (find tm (in-topicmaps assoc :revision 0)))
+ (is-true (find-if #'(lambda(role)
+ (and (eql (instance-of role :revision 0) it)
+ (eql (player role :revision 0) top-2)))
+ (roles assoc :revision 0))))
+ (signals exceptions:JTM-error
+ (jtm::make-instance-of-association top-1 top-3 nil :revision 100))
+ (delete-psi
+ tt (elephant:get-instance-by-value 'PersistentIdc 'd:uri *type-psi*)
+ :revision 200)
+ (signals exceptions:missing-reference-error
+ (jtm::make-instance-of-association top-1 top-3 (list tm) :revision 200))
+ )))
+
;TODO:
; *import-topic-stubs-from-jtm-lists
; *import-topic-stub-from-jtm-list
-; *make-instance-of-association
; *merge-topics-from-jtm-lists
; *merge-topic-from-jtm-list
Modified: trunk/src/xml/xtm/importer.lisp
==============================================================================
--- trunk/src/xml/xtm/importer.lisp (original)
+++ trunk/src/xml/xtm/importer.lisp Sun May 8 12:53:59 2011
@@ -130,6 +130,7 @@
(from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm")))
(add-to-tm tm top)))))))
+
;TODO: replace the two importers with this macro
(defmacro importer-mac
(get-topic-elems get-association-elems
More information about the Isidorus-cvs
mailing list