[isidorus-cvs] r217 - in branches/new-datamodel: docs src/model src/unit_tests - isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

27 Feb 2010

Author: lgiessmann
Date: Sat Feb 27 06:37:56 2010
New Revision: 217
Log:
new-datamodel: added some unit-tests for the class TopicMapC; added the generics add-to-tm and delete-from-tm.
Modified:
   branches/new-datamodel/docs/isidorus_data_model.pdf
   branches/new-datamodel/docs/isidorus_data_model.vsd
   branches/new-datamodel/src/model/datamodel.lisp
   branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/docs/isidorus_data_model.pdf
==============================================================================
Binary files branches/new-datamodel/docs/isidorus_data_model.pdf	(original) and branches/new-datamodel/docs/isidorus_data_model.pdf	Sat Feb 27 06:37:56 2010 differ
Modified: branches/new-datamodel/docs/isidorus_data_model.vsd
==============================================================================
Binary files. No diff available.
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================

--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Sat Feb 27 06:37:56 2010
@@ -25,7 +25,7 @@
       :TopicIdentificationC
       :TopicC
-	   ;;methods and functions
+	   ;;methods, functions and macros
       :xtm-id
       :uri
       :identified-construct
@@ -56,6 +56,8 @@
       :delete-role
       :associations
       :topics
+	   :add-to-tm
+	   :delete-from-tm
       :psis
       :add-psi
       :delete-psi
@@ -86,6 +88,7 @@
       :get-item-by-item-identifier
       :get-item-by-locator
       :string-integer-p
+	   :with-revision
;;globals
       :*TM-REVISION*
@@ -281,11 +284,11 @@
(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC)
-  ((topics :accessor topics
-	   :associate (TopicC in-topicmaps)
+  ((topics :associate (TopicC in-topicmaps)
+	   :many-to-many t
       :documentation "List of topics that explicitly belong to this TM.")
-   (associations :accessor associations
-                 :associate (AssociationC in-topicmaps)
+   (associations :associate (AssociationC in-topicmaps)
+		 :many-to-many t
                  :documentation "List of associations that belong to this TM."))
   (:documentation "Represnets a topic map."))
@@ -557,6 +560,12 @@
;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defmacro with-revision (revision &rest body)
+  `(let
+       ((*TM-REVISION* ,revision))
+     ,@body))
+
+
 (defun slot-p (instance slot-symbol)
   "Returns t if the slot depending on slot-symbol is bound and not nil."
   (if (slot-boundp instance slot-symbol)
@@ -1803,7 +1812,45 @@
       construct)))
+;;; TopicMapC
+(defgeneric topics (construct &key revision)
+  (:documentation "Returns all TopicC-objects that are contained in the tm.")
+  (:method ((construct TopicMapC) &key (revision 0))
+    (filter-slot-value-by-revision construct 'topics
+				   :start-revision revision)))
+
+
+(defgeneric associations (construct &key revision)
+  (:documentation "Returns all AssociationC-objects that are contained in the tm.")
+  (:method ((construct TopicMapC) &key (revision 0))
+    (filter-slot-value-by-revision construct 'associations
+				   :start-revision revision)))
+
+
+(defgeneric add-to-tm (construct construct-to-add)
+  (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM."))
+
+
+(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC))
+  (add-association construct 'topics construct-to-add))
+
+
+(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC))
+  (add-association construct 'associations construct-to-add))
+
+
+(defgeneric delete-from-tm (construct construct-to-delete)
+  (:documentation "Deletes a TM construct (TopicC or AssociationC) from
+                   the TM."))
+
+
+(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC))
+  (remove-association construct 'topics construct-to-delete))
+
+(defmethod delete-from-tm ((construct TopicMapC)
+			   (construct-to-delete AssociationC))
+  (remove-association construct 'associations construct-to-delete))
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp	(original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp	Sat Feb 27 06:37:56 2010
@@ -35,7 +35,8 @@
       :test-TypableC
       :test-ScopableC
       :test-RoleC
-	   :test-player))
+	   :test-player
+	   :test-TopicMapC))
;;TODO: test delete-construct
@@ -868,10 +869,57 @@
       (is (= (length (union (list role-1 role-2)
    		    (player-in-roles top-1))) 2))
       (is (= (length (slot-value top-1 'd::player-in-roles)) 2)))))
+
+
+(test test-TopicMapC ()
+  "Tests various function of the class TopicMapC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((tm-1 (make-instance 'TopicMapC))
+	  (tm-2 (make-instance 'TopicMapC))
+	  (top-1 (make-instance 'TopicC))
+	  (assoc-1 (make-instance 'AssociationC))
+	  (revision-0-5 50)
+	  (revision-1 100))
+      (setf *TM-REVISION* revision-1)
+      (is-false (topics tm-1))
+      (is-false (in-topicmaps top-1))
+      (is-false (in-topicmaps assoc-1))
+      (d::add-to-version-history top-1 :start-revision revision-1)
+      (add-to-tm tm-1 top-1)
+      (is (= (length (union (list top-1)
+			    (topics tm-1))) 1))
+      (is (= (length (union (list tm-1)
+			    (in-topicmaps top-1))) 1))
+      (is-false (topics tm-1 :revision revision-0-5))
+      (is-false (in-topicmaps top-1 :revision revision-0-5))
+      (d::add-to-version-history assoc-1 :start-revision revision-1)
+      (add-to-tm tm-1 assoc-1)
+      (is (= (length (union (list assoc-1)
+			    (associations tm-1))) 1))
+      (is (= (length (union (list tm-1)
+			    (in-topicmaps assoc-1))) 1))
+      (is-false (associations tm-1 :revision revision-0-5))
+      (is-false (in-topicmaps assoc-1 :revision revision-0-5))
+      (add-to-tm tm-2 top-1)
+      (is (= (length (union (list top-1)
+			    (topics tm-2))) 1))
+      (is (= (length (union (list tm-2 tm-1)
+			    (in-topicmaps top-1))) 2))
+      (is-false (topics tm-2 :revision revision-0-5))
+      (is-false (in-topicmaps top-1 :revision revision-0-5))
+      (d::add-to-version-history assoc-1 :start-revision revision-1)
+      (add-to-tm tm-2 assoc-1)
+      (is (= (length (union (list assoc-1)
+			    (associations tm-2))) 1))
+      (is (= (length (union (list tm-2 tm-1)
+			    (in-topicmaps assoc-1))) 2))
+      (is-false (associations tm-2 :revision revision-0-5))
+      (is-false (in-topicmaps assoc-1 :revision revision-0-5)))))
(defun run-datamodel-tests()
+  "Runs all tests of this test-suite."
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
   (it.bese.fiveam:run! 'test-ItemIdentifierC)
@@ -890,4 +938,4 @@
   (it.bese.fiveam:run! 'test-ScopableC)
   (it.bese.fiveam:run! 'test-RoleC)
   (it.bese.fiveam:run! 'test-player)
-)
\ No newline at end of file
+  (it.bese.fiveam:run! 'test-TopicMapC))
\ No newline at end of file

    