[isidorus-cvs] r227 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Mar 16 11:32:29 UTC 2010
Author: lgiessmann
Date: Tue Mar 16 07:32:28 2010
New Revision: 227
Log:
new-datamodel: added some unit-tests for equivalent-constructs --> OccurrenceC, NameC, VariantC; changed some "dangerous" code-sections in equivalent-construct
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Mar 16 07:32:28 2010
@@ -1445,32 +1445,42 @@
;;; 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))
@@ -1759,9 +1769,11 @@
&key (start-revision 0))
(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)))))
(defmethod delete-construct :before ((construct ReifiableConstructC))
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 Tue Mar 16 07:32:28 2010
@@ -16,6 +16,8 @@
:unittests-constants)
(:import-from :exceptions
duplicate-identifier-error)
+ (:import-from :constants
+ *xml-string*)
(:export :run-datamodel-tests
:datamodel-test
:test-VersionInfoC
@@ -48,7 +50,10 @@
:test-delete-ScopableC
:test-delete-AssociationC
:test-delete-RoleC
- :test-equivalent-PointerC))
+ :test-equivalent-PointerC
+ :test-equivalent-OccurrenceC
+ :test-equivalent-NameC
+ :test-equivalent-VariantC))
;;TODO: test merge-constructs when merging was caused by an item-dentifier,
@@ -1356,6 +1361,136 @@
(is-false (d::equivalent-construct psi-1 :uri "psi-2")))))
+(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."
(it.bese.fiveam:run! 'test-VersionInfoC)
@@ -1389,4 +1524,7 @@
(it.bese.fiveam:run! 'test-delete-AssociationC)
(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)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list