[isidorus-cvs] r243 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Mar 22 11:54:28 UTC 2010
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)))))
More information about the Isidorus-cvs
mailing list