Changeset 227

Timestamp:

03/16/10 11:32:28 (15 years ago)

Author:

lgiessmann

Message:

new-datamodel: added some unit-tests for equivalent-constructs --> OccurrenceC, NameC, VariantC; changed some "dangerous" code-sections in equivalent-construct

Location:

branches/new-datamodel/src

Files:

• model/datamodel.lisp (modified) (2 diffs)
• unit_tests/datamodel_test.lisp (modified) (4 diffs)

branches/new-datamodel/src/model/datamodel.lisp ¶

@@ -1446 +1446 @@
 ;;; OccurrenceC
 (defmethod equivalent-construct ((construct OccurrenceC)
-                                 &key (start-revision 0) (charvalue "")
+                                 &key (start-revision 0) (reifier nil)
+                                 (item-identifiers nil) (charvalue "")
                                  (themes nil) (instance-of nil)
-                                 (datatype *xml-string*))
+                                 (datatype ""))
   (declare (type (or null TopicC) instance-of) (string datatype)
-           (ignorable start-revision charvalue themes instance-of))
+           (ignorable start-revision charvalue themes instance-of
+                      reifier item-identifiers))
   (let ((equivalent-characteristic (call-next-method)))
-    (and equivalent-characteristic 
-         (string= (datatype construct) datatype))))
+    (or (and equivalent-characteristic 
+             (string= (datatype construct) datatype))
+        (equivalent-reifiable-construct construct reifier item-identifiers
+                                        :start-revision start-revision))))
 
 
 ;;; VariantC
 (defmethod equivalent-construct ((construct VariantC)
-                                 &key (start-revision 0) (charvalue "")
-                                 (themes nil) (datatype *xml-string*))
-  (declare (string datatype) (ignorable start-revision charvalue themes))
+                                 &key (start-revision 0) (reifier nil)
+                                 (item-identifiers nil) (charvalue "")
+                                 (themes nil) (datatype ""))
+  (declare (string datatype) (ignorable start-revision charvalue themes
+                                        reifier item-identifiers))
   (let ((equivalent-characteristic (call-next-method)))
-    (and equivalent-characteristic 
-         (string= (datatype construct) datatype))))
+    (or (and equivalent-characteristic 
+             (string= (datatype construct) datatype))
+        (equivalent-reifiable-construct construct reifier item-identifiers
+                                        :start-revision start-revision))))
 
 
 ;;; NameC
 (defmethod equivalent-construct ((construct NameC)
-                                 &key (start-revision 0) (charvalue "")
+                                 &key (start-revision 0) (reifier nil)
+                                 (item-identifiers nil) (charvalue "")
                                  (themes nil) (instance-of nil))
   (declare (type (or null TopicC) instance-of)
-           (ignorable start-revision charvalue instance-of themes))
+           (ignorable start-revision charvalue instance-of themes
+                      reifier item-identifiers))
   (call-next-method))
   
@@ -1760 +1770 @@
     (declare (integer start-revision) (list item-identifiers)
              (type (or null TopicC) reifier))
-    (or (eql reifier (reifier construct :revision start-revision))
-        (intersection (item-identifiers construct :revision start-revision)
-                      item-identifiers))))
+    (or (and (reifier construct :revision start-revision)
+             (eql reifier (reifier construct :revision start-revision)))
+        (and (item-identifiers construct :revision start-revision)
+             (intersection (item-identifiers construct :revision start-revision)
+                           item-identifiers)))))
 
 

branches/new-datamodel/src/unit_tests/datamodel_test.lisp ¶

@@ -17 +17 @@
   (:import-from :exceptions
                 duplicate-identifier-error)
+  (:import-from :constants
+                *xml-string*)
   (:export :run-datamodel-tests
            :datamodel-test
@@ -49 +51 @@
            :test-delete-AssociationC
            :test-delete-RoleC
-           :test-equivalent-PointerC))
+           :test-equivalent-PointerC
+           :test-equivalent-OccurrenceC
+           :test-equivalent-NameC
+           :test-equivalent-VariantC))
 
 
@@ -1357 +1362 @@
 
 
+(test test-equivalent-OccurrenceC ()
+  "Tests the functions equivalent-construct depending on OccurrenceC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((occ-1 (make-instance 'd:OccurrenceC :charvalue "occ-1"))
+          (type-1 (make-instance 'd:TopicC))
+          (type-2 (make-instance 'd:TopicC))
+          (scope-1 (make-instance 'd:TopicC))
+          (scope-2 (make-instance 'd:TopicC))
+          (scope-3 (make-instance 'd:TopicC))
+          (reifier-1 (make-instance 'd:TopicC))
+          (reifier-2 (make-instance 'd:TopicC))
+          (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
+          (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
+          (revision-0-5 50)
+          (version-1 100))
+      (setf *TM-REVISION* version-1)
+      (add-type occ-1 type-1)
+      (add-theme occ-1 scope-1)
+      (add-theme occ-1 scope-2)
+      (is-true (d::equivalent-construct
+                occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
+                :instance-of type-1 :themes (list scope-2 scope-1)))
+      (is-false (d::equivalent-construct
+                 occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
+                 :instance-of type-1 :themes (list scope-2 scope-1)
+                 :start-revision revision-0-5))
+      (is-false (d::equivalent-construct
+                 occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
+                 :instance-of type-2 :themes (list scope-1 scope-2)))
+      (is-false (d::equivalent-construct
+                 occ-1 :charvalue "occ-1" :datatype constants:*xml-string*
+                 :instance-of type-1 :themes (list scope-3 scope-2)))
+      (is-false (d::equivalent-construct
+                 occ-1 :charvalue "occ-1"
+                 :instance-of type-1 :themes (list scope-1 scope-2)))
+      (is-false (d::equivalent-construct
+                 occ-1 :charvalue "occ-2" :datatype constants:*xml-string*
+                 :instance-of type-1 :themes (list scope-2 scope-1)))
+      (add-item-identifier occ-1 ii-1)
+      (is-true (d::equivalent-construct occ-1 :item-identifiers (list ii-1)))
+      (is-false (d::equivalent-construct occ-1 :item-identifiers (list ii-2)))
+      (add-reifier occ-1 reifier-1)
+      (is-true (d::equivalent-construct occ-1 :reifier reifier-1))
+      (is-false (d::equivalent-construct occ-1 :reifier reifier-2)))))
+
+
+(test test-equivalent-NameC ()
+  "Tests the functions equivalent-construct depending on NameC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((nam-1 (make-instance 'd:NameC :charvalue "nam-1"))
+          (type-1 (make-instance 'd:TopicC))
+          (type-2 (make-instance 'd:TopicC))
+          (scope-1 (make-instance 'd:TopicC))
+          (scope-2 (make-instance 'd:TopicC))
+          (scope-3 (make-instance 'd:TopicC))
+          (reifier-1 (make-instance 'd:TopicC))
+          (reifier-2 (make-instance 'd:TopicC))
+          (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
+          (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
+          (revision-0-5 50)
+          (version-1 100))
+      (setf *TM-REVISION* version-1)
+      (add-type nam-1 type-1)
+      (add-theme nam-1 scope-1)
+      (add-theme nam-1 scope-2)
+      (is-true (d::equivalent-construct
+                nam-1 :charvalue "nam-1" :instance-of type-1
+                :themes (list scope-2 scope-1)))
+      (is-false (d::equivalent-construct
+                 nam-1 :charvalue "nam-1" :instance-of type-1
+                 :themes (list scope-2 scope-1)
+                 :start-revision revision-0-5))
+      (is-false (d::equivalent-construct
+                 nam-1 :charvalue "nam-1" :instance-of type-2
+                 :themes (list scope-1 scope-2)))
+      (is-false (d::equivalent-construct
+                 nam-1 :charvalue "nam-1" :instance-of type-1
+                 :themes (list scope-3 scope-2)))
+      (is-false (d::equivalent-construct
+                 nam-1 :charvalue "nam-2" :instance-of type-1
+                 :themes (list scope-2 scope-1)))
+      (add-item-identifier nam-1 ii-1)
+      (is-true (d::equivalent-construct nam-1 :item-identifiers (list ii-1)))
+      (is-false (d::equivalent-construct nam-1 :item-identifiers (list ii-2)))
+      (add-reifier nam-1 reifier-1)
+      (is-true (d::equivalent-construct nam-1 :reifier reifier-1))
+      (is-false (d::equivalent-construct nam-1 :reifier reifier-2)))))
+
+
+(test test-equivalent-VariantC ()
+  "Tests the functions equivalent-construct depending on VariantC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((var-1 (make-instance 'd:OccurrenceC :charvalue "var-1"))
+          (scope-1 (make-instance 'd:TopicC))
+          (scope-2 (make-instance 'd:TopicC))
+          (scope-3 (make-instance 'd:TopicC))
+          (reifier-1 (make-instance 'd:TopicC))
+          (reifier-2 (make-instance 'd:TopicC))
+          (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
+          (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
+          (revision-0-5 50)
+          (version-1 100))
+      (setf *TM-REVISION* version-1)
+      (add-theme var-1 scope-1)
+      (add-theme var-1 scope-2)
+      (is-true (d::equivalent-construct
+                var-1 :charvalue "var-1" :datatype constants:*xml-string*
+                :themes (list scope-2 scope-1)))
+      (is-false (d::equivalent-construct
+                 var-1 :charvalue "var-1" :datatype constants:*xml-string*
+                 :themes (list scope-2 scope-1)
+                 :start-revision revision-0-5))
+      (is-false (d::equivalent-construct
+                 var-1 :charvalue "var-1" :datatype constants:*xml-string*
+                 :themes (list scope-3 scope-2)))
+      (is-false (d::equivalent-construct
+                 var-1 :charvalue "var-1"
+                 :themes (list scope-1 scope-2)))
+      (is-false (d::equivalent-construct
+                 var-1 :charvalue "var-2" :datatype constants:*xml-string*
+                 :themes (list scope-2 scope-1)))
+      (add-item-identifier var-1 ii-1)
+      (is-true (d::equivalent-construct var-1 :item-identifiers (list ii-1)))
+      (is-false (d::equivalent-construct var-1 :item-identifiers (list ii-2)))
+      (add-reifier var-1 reifier-1)
+      (is-true (d::equivalent-construct var-1 :reifier reifier-1))
+      (is-false (d::equivalent-construct var-1 :reifier reifier-2)))))
+
+
+
 (defun run-datamodel-tests()
   "Runs all tests of this test-suite."
@@ -1390 +1525 @@
   (it.bese.fiveam:run! 'test-delete-RoleC)
   (it.bese.fiveam:run! 'test-equivalent-PointerC)
+  (it.bese.fiveam:run! 'test-equivalent-OccurrenceC)
+  (it.bese.fiveam:run! 'test-equivalent-NameC)
+  (it.bese.fiveam:run! 'test-equivalent-VariantC)
   )