[isidorus-cvs] r211 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Feb 26 07:58:58 UTC 2010
Author: lgiessmann
Date: Fri Feb 26 02:58:57 2010
New Revision: 211
Log:
new-datamodel: merged the generic functions delete-parent, so there is only one generic function with the signature ((construct CharacteristicC) (parent-construct ReifiableConstructC)
&key (revision (error "From delete-parent(): revision must be set"))); added some unit-tests for the class VariantC
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:58:57 2010
@@ -493,7 +493,7 @@
associates characteristics with topics."))
-(defpclass VariantAssociationC(CharateristicAssociationC)
+(defpclass VariantAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
:initform (error "From VariantAssociationC(): parent-construct must be set")
@@ -1187,8 +1187,8 @@
scopable-construct.")
(:method ((construct NameC) (variant VariantC)
&key (revision *TM-REVISION*))
- (when (and (parent variant)
- (not (eql (parent variant) construct)))
+ (when (and (parent variant :revision revision)
+ (not (eql (parent variant :revision revision) 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
@@ -1285,29 +1285,16 @@
(defgeneric delete-parent (construct parent-construct &key revision)
(:documentation "Sets the assoication-object between the passed
- constructs as marded-as-deleted."))
-
-
-(defmethod delete-parent ((construct CharacteristicC) (parent-construct TopicC)
- &key (revision (error "From delete-parent(): revision must be set")))
- (let ((assoc-to-delete
- (loop for parent-assoc in (slot-p construct 'parent)
- when (eql (parent-construct parent-assoc) parent-construct)
- return parent-assoc)))
- (when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- construct))
-
-
-(defmethod delete-parent ((construct CharacteristicC) (parent-construct NameC)
- &key (revision (error "From delete-parent(): revision must be set")))
- (let ((assoc-to-delete
- (loop for parent-assoc in (slot-p construct 'parent)
- when (eql (characteristic parent-assoc) parent-construct)
- return parent-assoc)))
- (when assoc-to-delete
- (mark-as-deleted assoc-to-delete :revision revision))
- construct))
+ constructs as marded-as-deleted.")
+ (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC)
+ &key (revision (error "From delete-parent(): revision must be set")))
+ (let ((assoc-to-delete
+ (loop for parent-assoc in (slot-p construct 'parent)
+ when (eql (parent-construct parent-assoc) parent-construct)
+ return parent-assoc)))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision))
+ construct)))
;;; PlayerAssociationC
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:58:57 2010
@@ -518,7 +518,7 @@
(with-fixture with-empty-db (*db-dir*)
(let ((occ-1 (make-instance 'OccurrenceC))
(occ-2 (make-instance 'OccurrenceC))
- (top (make-instance 'TopicC))
+ (top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
(revision-1 100)
(revision-2 200)
@@ -530,46 +530,46 @@
(revision-8 800))
(setf *TM-REVISION* revision-1)
(is-false (parent occ-1))
- (is-false (occurrences top))
- (add-occurrence top occ-1 :revision revision-1)
+ (is-false (occurrences top-1))
+ (add-occurrence top-1 occ-1 :revision revision-1)
(is (= (length (union (list occ-1)
- (occurrences top))) 1))
- (add-occurrence top occ-2 :revision revision-2)
+ (occurrences top-1))) 1))
+ (add-occurrence top-1 occ-2 :revision revision-2)
(is (= (length (union (list occ-1 occ-2)
- (occurrences top))) 2))
+ (occurrences top-1))) 2))
(is (= (length (union (list occ-1)
- (occurrences top :revision revision-1))) 1))
- (add-occurrence top occ-2 :revision revision-3)
- (is (= (length (d::slot-p top 'd::occurrences)) 2))
- (delete-occurrence top occ-1 :revision revision-4)
+ (occurrences top-1 :revision revision-1))) 1))
+ (add-occurrence top-1 occ-2 :revision revision-3)
+ (is (= (length (d::slot-p top-1 'd::occurrences)) 2))
+ (delete-occurrence top-1 occ-1 :revision revision-4)
(is (= (length (union (list occ-2)
- (occurrences top :revision revision-4))) 1))
+ (occurrences top-1 :revision revision-4))) 1))
(is (= (length (union (list occ-2)
- (occurrences top))) 1))
+ (occurrences top-1))) 1))
(is (= (length (union (list occ-1 occ-2)
- (occurrences top :revision revision-2))) 2))
- (add-occurrence top occ-1 :revision revision-4)
+ (occurrences top-1 :revision revision-2))) 2))
+ (add-occurrence top-1 occ-1 :revision revision-4)
(is (= (length (union (list occ-2 occ-1)
- (occurrences top))) 2))
+ (occurrences top-1))) 2))
(signals error (add-occurrence top-2 occ-1 :revision revision-4))
- (delete-occurrence top occ-1 :revision revision-5)
+ (delete-occurrence top-1 occ-1 :revision revision-5)
(is (= (length (union (list occ-2)
- (occurrences top :revision revision-5))) 1))
+ (occurrences top-1 :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 (eql (parent occ-1 :revision revision-2) top-1))
+ (delete-parent occ-2 top-1 :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 (eql top-1 (parent occ-2 :revision revision-3)))
+ (add-parent occ-2 top-1 :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)
+ (is (eql top-1 (parent occ-2)))
+ (delete-parent occ-2 top-1 :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))))))
+ (add-parent occ-2 top-1 :revision revision-8)
+ (is (eql top-1 (parent occ-2))))))
(test test-VariantC ()
@@ -577,14 +577,59 @@
(with-fixture with-empty-db (*db-dir*)
(let ((v-1 (make-instance 'VariantC))
(v-2 (make-instance 'VariantC))
- (name (make-instance 'NameC))
+ (name-1 (make-instance 'NameC))
+ (name-2 (make-instance 'NameC))
(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 v-1))
+ (is-false (variants name-1))
+ (add-variant name-1 v-1 :revision revision-1)
+ (is (= (length (union (list v-1)
+ (variants name-1))) 1))
+ (add-variant name-1 v-2 :revision revision-2)
+ (is (= (length (union (list v-1 v-2)
+ (variants name-1))) 2))
+ (is (= (length (union (list v-1)
+ (variants name-1 :revision revision-1))) 1))
+ (add-variant name-1 v-2 :revision revision-3)
+ (is (= (length (d::slot-p name-1 'd::variants)) 2))
+ (delete-variant name-1 v-1 :revision revision-4)
+ (is (= (length (union (list v-2)
+ (variants name-1 :revision revision-4))) 1))
+ (is (= (length (union (list v-2)
+ (variants name-1))) 1))
+ (is (= (length (union (list v-1 v-2)
+ (variants name-1 :revision revision-2))) 2))
+ (add-variant name-1 v-1 :revision revision-4)
+ (is (= (length (union (list v-2 v-1)
+ (variants name-1))) 2))
+ (signals error (add-variant name-2 v-1 :revision revision-4))
+ (delete-variant name-1 v-1 :revision revision-5)
+ (is (= (length (union (list v-2)
+ (variants name-1 :revision revision-5))) 1))
+ (add-variant name-2 v-1 :revision revision-5)
+ (is (eql (parent v-1) name-2))
+ (is (eql (parent v-1 :revision revision-2) name-1))
+ (delete-parent v-2 name-1 :revision revision-4)
+ (format t "-->")
+ (is-false (parent v-2 :revision revision-4))
+ (is (eql name-1 (parent v-2 :revision revision-3)))
+ (add-parent v-2 name-1 :revision revision-5)
+ (is-false (parent v-2 :revision revision-4))
+ (is (eql name-1 (parent v-2)))
+ (delete-parent v-2 name-1 :revision revision-6)
+ (add-parent v-2 name-2 :revision revision-7)
+ (delete-parent v-2 name-2 :revision revision-8)
+ (is-false (parent v-2))
+ (add-parent v-2 name-1 :revision revision-8)
+ (is (eql name-1 (parent v-2))))))
More information about the Isidorus-cvs
mailing list