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