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))))))