Author: lgiessmann Date: Mon Mar 22 07:54:27 2010 New Revision: 243

Log: new-datamodel: added "make-construct" for VersionedAssocitionC and unknown classes via "(apply make-instance class-symbol args)" replaced all "make-instance" and "add-to-version-history" calls by "make-construct" in all add-<whatever> generics

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 Mon Mar 22 07:54:27 2010 @@ -146,6 +146,7 @@ :changed-p :check-for-duplicate-identifiers :find-item-by-content + :rec-remf

;;globals :*TM-REVISION* @@ -161,8 +162,6 @@ ;; and the parent's parent construct), add-psi, add-locator ;; (--> duplicate-identifier-error) ;;TODO: finalize add-reifier -;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo -;; initarg in make-construct ;;TODO: implement a macro "with-merge-construct" that merges constructs ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done @@ -623,6 +622,15 @@

;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun rec-remf (plist keyword) + "Calls remf for the past plist with the given keyword until + all key-value-pairs corresponding to the passed keyword were removed." + (declare (list plist) (keyword keyword)) + (loop while (getf plist keyword) + do (remf plist keyword)) + plist) + + (defun get-item-by-content (content &key (revision *TM-REVISION*)) "Finds characteristics by their (atomic) content." (flet @@ -1220,10 +1228,10 @@ return ti-assoc))) (add-to-version-history ti-assoc :start-revision revision))) (t - (let ((assoc (make-instance 'TopicIdAssociationC - :parent-construct construct - :identifier topic-identifier))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'TopicIdAssociationC + :parent-construct construct + :identifier topic-identifier + :start-revision revision))) (add-to-version-history merged-construct :start-revision revision) merged-construct))))

@@ -1275,10 +1283,10 @@ return psi-assoc))) (add-to-version-history psi-assoc :start-revision revision))) (t - (let ((assoc (make-instance 'PersistentIdAssociationC - :parent-construct construct - :identifier psi))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'PersistentIdAssociationC + :parent-construct construct + :identifier psi + :start-revision revision))) (add-to-version-history merged-construct :start-revision revision) merged-construct))))

@@ -1331,11 +1339,10 @@ return loc-assoc))) (add-to-version-history loc-assoc :start-revision revision))) (t - (let ((assoc - (make-instance 'SubjectLocatorAssociationC - :parent-construct construct - :identifier locator))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator + :start-revision revision))) (add-to-version-history merged-construct :start-revision revision) merged-construct))))

@@ -1390,11 +1397,10 @@ construct) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) - (let ((assoc - (make-instance 'NameAssociationC - :parent-construct construct - :characteristic name))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'NameAssociationC + :parent-construct construct + :characteristic name + :start-revision revision))) (add-to-version-history construct :start-revision revision) construct))

@@ -1440,11 +1446,10 @@ when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) - (let ((assoc - (make-instance 'OccurrenceAssociationC - :parent-construct construct - :characteristic occurrence))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'OccurrenceAssociationC + :parent-construct construct + :characteristic occurrence + :start-revision revision))) (add-to-version-history construct :start-revision revision) construct))

@@ -1732,10 +1737,10 @@ 'NameAssociationC) (t 'VariantAssociationC)))) - (let ((assoc (make-instance association-type - :characteristic construct - :parent-construct parent-construct))) - (add-to-version-history assoc :start-revision revision)))))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision))))) construct))

@@ -1864,11 +1869,10 @@ when (eql (characteristic variant-assoc) variant) return variant-assoc))) (add-to-version-history variant-assoc :start-revision revision)) - (let ((assoc - (make-instance 'VariantAssociationC - :characteristic variant - :parent-construct construct))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'VariantAssociationC + :characteristic variant + :parent-construct construct + :start-revision revision))) construct))

@@ -1949,11 +1953,10 @@ when (eql (role role-assoc) role) return role-assoc))) (add-to-version-history role-assoc :start-revision revision)) - (let ((assoc - (make-instance 'RoleAssociationC - :role role - :parent-construct construct))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'RoleAssociationC + :role role + :parent-construct construct + :start-revision revision))) (add-to-version-history construct :start-revision revision) construct))

@@ -2043,10 +2046,10 @@ (same-parent-assoc (add-to-version-history same-parent-assoc :start-revision revision)) (t - (let ((assoc (make-instance 'RoleAssociationC - :role construct - :parent-construct parent-construct))) - (add-to-version-history assoc :start-revision revision))))) + (make-construct 'RoleAssociationC + :role construct + :parent-construct parent-construct + :start-revision revision)))) (add-to-version-history parent-construct :start-revision revision) construct)

@@ -2095,10 +2098,10 @@ (same-player-assoc (add-to-version-history same-player-assoc :start-revision revision)) (t - (let ((assoc (make-instance 'PlayerAssociationC - :parent-construct construct - :player-topic player-topic))) - (add-to-version-history assoc :start-revision revision))))) + (make-construct 'PlayerAssociationC + :parent-construct construct + :player-topic player-topic + :start-revision revision)))) construct))

@@ -2237,10 +2240,10 @@ return ii-assoc))) (add-to-version-history ii-assoc :start-revision revision))) (t - (let ((assoc (make-instance 'ItemIdAssociationC - :parent-construct construct - :identifier item-identifier))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'ItemIdAssociationC + :parent-construct construct + :identifier item-identifier + :start-revision revision))) (when (or (typep merged-construct 'TopicC) (typep merged-construct 'AssociationC) (typep merged-construct 'TopicMapC)) @@ -2291,10 +2294,10 @@ (all-constructs (merge-constructs (first all-constructs) construct)) (t - (let ((assoc (make-instance 'ReifierAssociationC - :reifiable-construct construct - :reifier-topic merged-reifier-topic))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'ReifierAssociationC + :reifiable-construct construct + :reifier-topic merged-reifier-topic + :start-revision revision))) (when (or (typep merged-construct 'TopicC) (typep merged-construct 'AssociationC) (typep merged-construct 'TopicMapC)) @@ -2409,11 +2412,10 @@ when (eql (theme-topic theme-assoc) theme-topic) return theme-assoc))) (add-to-version-history theme-assoc :start-revision revision)) - (let ((assoc - (make-instance 'ScopeAssociationC - :theme-topic theme-topic - :scopable-construct construct))) - (add-to-version-history assoc :start-revision revision)))) + (make-construct 'ScopeAssociationC + :theme-topic theme-topic + :scopable-construct construct + :start-revision revision))) (when (typep construct 'AssociationC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2481,11 +2483,10 @@ (same-type-assoc (add-to-version-history same-type-assoc :start-revision revision)) (t - (let ((assoc - (make-instance 'TypeAssociationC - :type-topic type-topic - :typable-construct construct))) - (add-to-version-history assoc :start-revision revision))))) + (make-construct 'TypeAssociationC + :type-topic type-topic + :typable-construct construct + :start-revision revision)))) (when (typep construct 'AssociationC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2582,6 +2583,8 @@ (apply #'make-role args)) ((AssociationC-p class-symbol) (apply #'make-association args)) + ((VersionedConstructC-p class-symbol) + (apply #'make-instance (rec-remf args :start-revision))) (t (apply #'make-instance class-symbol args)))) (start-revision (getf args :start-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 Mon Mar 22 07:54:27 2010 @@ -908,7 +908,6 @@ (topics tm-1))) 1)) (is (= (length (union (list tm-1) (in-topicmaps top-1))) 1)) - (is-false (topics tm-1 :revision revision-0-5)) (is-false (in-topicmaps top-1 :revision revision-0-5)) (d::add-to-version-history assoc-1 :start-revision revision-1) (add-to-tm tm-1 assoc-1) @@ -916,14 +915,12 @@ (associations tm-1))) 1)) (is (= (length (union (list tm-1) (in-topicmaps assoc-1))) 1)) - (is-false (associations tm-1 :revision revision-0-5)) (is-false (in-topicmaps assoc-1 :revision revision-0-5)) (add-to-tm tm-2 top-1) (is (= (length (union (list top-1) (topics tm-2))) 1)) (is (= (length (union (list tm-2 tm-1) (in-topicmaps top-1))) 2)) - (is-false (topics tm-2 :revision revision-0-5)) (is-false (in-topicmaps top-1 :revision revision-0-5)) (d::add-to-version-history assoc-1 :start-revision revision-1) (add-to-tm tm-2 assoc-1) @@ -931,7 +928,6 @@ (associations tm-2))) 1)) (is (= (length (union (list tm-2 tm-1) (in-topicmaps assoc-1))) 2)) - (is-false (associations tm-2 :revision revision-0-5)) (is-false (in-topicmaps assoc-1 :revision revision-0-5)))))