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