[isidorus-cvs] r210 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Feb 26 07:14:12 UTC 2010
Author: lgiessmann
Date: Fri Feb 26 02:14:11 2010
New Revision: 210
Log:
new-datamodel: merged the generic functions add-parent, so there is only one for the parents TopicC and NameC; added some unit-tests for add-parent, delete-parent and parent
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 Fri Feb 26 02:14:11 2010
@@ -331,7 +331,7 @@
;;; characteristics ...
(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
- ((parent :associate (CharacteriticAssociationC characteristic)
+ ((parent :associate (CharacteristicAssociationC characteristic)
:inherit t
:documentation "Assocates the characterist obejct with the
parent-association.")
@@ -948,13 +948,12 @@
an error is thrown.")
(:method ((construct TopicC) (name NameC)
&key (revision *TM-REVISION*))
- (when (not (eql (parent name) construct))
+ (when (and (parent name)
+ (not (eql (parent name) construct)))
(error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
name construct (parent name)))
(let ((all-names
- (map 'list #'characteristic
- (remove-if #'marked-as-deleted-p
- (slot-p construct 'names)))))
+ (map 'list #'characteristic (slot-p construct 'names))))
(if (find name all-names)
(let ((name-assoc (loop for name-assoc in (slot-p construct 'names)
when (eql (parent-construct name-assoc) name)
@@ -998,14 +997,12 @@
an error is thrown.")
(:method ((construct TopicC) (occurrence OccurrenceC)
&key (revision *TM-REVISION*))
- (when (and (parent occurrence)
+ (when (and (parent occurrence :revision revision)
(not (eql (parent occurrence) construct)))
(error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
occurrence construct (parent occurrence)))
(let ((all-occurrences
- (map 'list #'characteristic
- (remove-if #'marked-as-deleted-p
- (slot-p construct 'occurrences)))))
+ (map 'list #'characteristic (slot-p construct 'occurrences))))
(if (find occurrence all-occurrences)
(let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
when (eql (parent-construct occ-assoc) construct)
@@ -1190,13 +1187,12 @@
scopable-construct.")
(:method ((construct NameC) (variant VariantC)
&key (revision *TM-REVISION*))
- (when (not (eql (parent variant) construct))
+ (when (and (parent variant)
+ (not (eql (parent variant) construct)))
(error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
variant construct (parent variant)))
(let ((all-variants
- (map 'list #'characteristic
- (remove-if #'marked-as-deleted-p
- (slot-p construct 'variants)))))
+ (map 'list #'characteristic (slot-p construct 'variants))))
(if (find variant all-variants)
(let ((variant-assoc
(loop for variant-assoc in (slot-p construct 'variants)
@@ -1252,60 +1248,39 @@
(defgeneric add-parent (construct parent-construct &key revision)
(:documentation "Adds the parent-construct (TopicC or NameC) in form of
- a corresponding association to the given object."))
-
-
-(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
- &key (revision *TM-REVISION*))
- (let ((already-set-topic
- (map 'list #'parent-construct
- (filter-slot-value-by-revision construct 'parent
- :start-revision revision))))
- (cond ((and already-set-topic
- (eql (first already-set-topic) parent-construct))
- (let ((parent-assoc
- (loop for parent-assoc in (slot-p construct 'parent)
- when (eql parent-construct (parent-construct
- parent-assoc))
- return parent-assoc)))
- (add-to-version-history parent-assoc :start-revision revision)))
- ((not already-set-topic)
- (let ((assoc
- (make-instance (if (typep construct 'OccurrenceC)
- 'OccurrenceAssociationC
- 'NameAssociationC)
- :parent-construct parent-construct
- :characteristic construct)))
- (add-to-version-history assoc :start-revision revision)))
- (t
- (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
- construct parent-construct already-set-topic)))
- construct))
-
-
-(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
- &key (revision *TM-REVISION*))
- (let ((already-set-name
- (map 'list #'characteristic
- (filter-slot-value-by-revision construct 'parent
- :start-revision revision))))
- (cond ((and already-set-name
- (eql (first already-set-name) parent-construct))
+ a corresponding association to the given object.")
+ (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (let ((already-set-parent (parent construct :revision revision))
+ (same-parent-assoc ;should contain a object that was marked as deleted
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql parent-construct (parent-construct parent-assoc))
+ return parent-assoc)))
+ (when (and already-set-parent
+ (not (eql already-set-parent parent-construct)))
+ (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+ construct parent-construct already-set-parent))
+ (cond (already-set-parent
(let ((parent-assoc
(loop for parent-assoc in (slot-p construct 'parent)
- when (eql parent-construct (characteristic parent-assoc))
+ when (eql parent-construct
+ (parent-construct parent-assoc))
return parent-assoc)))
(add-to-version-history parent-assoc :start-revision revision)))
- ((not already-set-name)
- (let ((assoc
- (make-instance 'VariantAssociationC
- :parent-construct parent-construct
- :characteristic construct)))
- (add-to-version-history assoc :start-revision revision)))
+ (same-parent-assoc
+ (add-to-version-history same-parent-assoc :start-revision revision))
(t
- (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
- construct parent-construct already-set-name)))
- construct))
+ (let ((association-type (cond ((typep construct 'OccurrenceC)
+ 'OccurrenceAssociationC)
+ ((typep construct 'NameC)
+ 'NameAssociationC)
+ (t
+ 'VariantAssociationC))))
+ (let ((assoc (make-instance association-type
+ :characteristic construct
+ :parent-construct parent-construct)))
+ (add-to-version-history assoc :start-revision revision))))))
+ construct))
(defgeneric delete-parent (construct parent-construct &key revision)
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 Fri Feb 26 02:14:11 2010
@@ -28,7 +28,8 @@
:test-get-item-by-locator
:test-get-item-by-psi
:test-ReifiableConstructC
- :test-OccurrenceC))
+ :test-OccurrenceC
+ :test-VariantC))
;;TODO: test delete-construct
@@ -518,10 +519,15 @@
(let ((occ-1 (make-instance 'OccurrenceC))
(occ-2 (make-instance 'OccurrenceC))
(top (make-instance 'TopicC))
+ (top-2 (make-instance 'TopicC))
(revision-1 100)
(revision-2 200)
(revision-3 300)
- (revision-4 400))
+ (revision-4 400)
+ (revision-5 500)
+ (revision-6 600)
+ (revision-7 700)
+ (revision-8 800))
(setf *TM-REVISION* revision-1)
(is-false (parent occ-1))
(is-false (occurrences top))
@@ -544,7 +550,42 @@
(occurrences top :revision revision-2))) 2))
(add-occurrence top occ-1 :revision revision-4)
(is (= (length (union (list occ-2 occ-1)
- (occurrences top))) 2)))))
+ (occurrences top))) 2))
+ (signals error (add-occurrence top-2 occ-1 :revision revision-4))
+ (delete-occurrence top occ-1 :revision revision-5)
+ (is (= (length (union (list occ-2)
+ (occurrences top :revision revision-5))) 1))
+ (add-occurrence top-2 occ-1 :revision revision-5)
+ (is (eql (parent occ-1) top-2))
+ (is (eql (parent occ-1 :revision revision-2) top))
+ (delete-parent occ-2 top :revision revision-4)
+ (is-false (parent occ-2 :revision revision-4))
+ (is (eql top (parent occ-2 :revision revision-3)))
+ (add-parent occ-2 top :revision revision-5)
+ (is-false (parent occ-2 :revision revision-4))
+ (is (eql top (parent occ-2)))
+ (delete-parent occ-2 top :revision revision-6)
+ (add-parent occ-2 top-2 :revision revision-7)
+ (delete-parent occ-2 top-2 :revision revision-8)
+ (is-false (parent occ-2))
+ (add-parent occ-2 top :revision revision-8)
+ (is (eql top (parent occ-2))))))
+
+
+(test test-VariantC ()
+"Tests various functions of VariantC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((v-1 (make-instance 'VariantC))
+ (v-2 (make-instance 'VariantC))
+ (name (make-instance 'NameC))
+ (revision-1 100)
+ (revision-2 200)
+ (revision-3 300)
+ (revision-4 400))
+ (setf *TM-REVISION* revision-1)
+
+ )))
+
(defun run-datamodel-tests()
@@ -560,4 +601,5 @@
(it.bese.fiveam:run! 'test-get-item-by-psi)
(it.bese.fiveam:run! 'test-ReifiableConstructC)
(it.bese.fiveam:run! 'test-OccurrenceC)
+ (it.bese.fiveam:run! 'test-VariantC)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list