[isidorus-cvs] r285 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Apr 22 10:51:40 UTC 2010
Author: lgiessmann
Date: Thu Apr 22 06:51:39 2010
New Revision: 285
Log:
new-datamodel: adapted the "mark-as-deleted" and "marked-as-deleted-p" methods to the new datamodel; added some unit-tests for mergeing topics
Modified:
branches/new-datamodel/src/model/changes.lisp
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/changes.lisp
==============================================================================
--- branches/new-datamodel/src/model/changes.lisp (original)
+++ branches/new-datamodel/src/model/changes.lisp Thu Apr 22 06:51:39 2010
@@ -7,7 +7,6 @@
;;+-----------------------------------------------------------------------------
-;-*- standard-indent:2; tab-width:2; indent-tabs-mode:nil -*-
(in-package :datamodel)
(defun get-all-revisions ()
@@ -36,19 +35,28 @@
(sort revision-set #'<)))
-(defun find-associations-for-topic (top)
- "find all associations of this topic"
+(defun find-all-associations-for-topic (top &key (revision *TM-REVISION*))
+ "Finds all associations for a topic."
+ (remove-duplicates
+ (map 'list #'(lambda(role)
+ (parent role :revision revision))
+ (player-in-roles top :revision revision))))
+
+
+(defun find-associations-for-topic (top &key (revision *TM-REVISION*))
+ "Finds all associations of this topic except type-instance-associations."
(let
((type-instance-topic
(d:identified-construct
(elephant:get-instance-by-value 'PersistentIdC
'uri
"http://psi.topicmaps.org/iso13250/model/type-instance"))))
- (remove
- type-instance-topic
- (remove-duplicates
- (map 'list #'parent (player-in-roles top)))
- :key #'instance-of)))
+ (remove-if
+ #'(lambda(assoc)
+ (when (eql (instance-of assoc :revision revision)
+ type-instance-topic)
+ t))
+ (find-all-associations-for-topic top :revision revision))))
(defgeneric find-referenced-topics (construct)
@@ -208,53 +216,9 @@
'unique-id
unique-id))
-;(defgeneric mark-as-deleted (construct &key source-locator revision)
-; (:documentation "Mark a construct as deleted if it comes from the source indicated by
-;source-locator"))
-
-;(defmethod mark-as-deleted ((construct TopicMapConstructC) &key source-locator revision)
-; "Mark a topic as deleted if it comes from the source indicated by
-;source-locator"
-; (declare (ignorable source-locator))
-; (let
-; ((last-version ;the last active version
-; (find 0 (versions construct) :key #'end-revision)))
-; (when last-version
-; (setf (end-revision last-version) revision))))
-;
-;(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
-; "Mark an association and its roles as deleted"
-; (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator))
-; (roles ass))
-; (call-next-method))
-;
-;(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision)
-; "Mark a topic as deleted if it comes from the source indicated by
-;source-locator"
-; ;;Part 1b, 1.4.3.3.1:
-; ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
-; ;; * Let SI be the value of TopicSI element in ATOM entry E
-; ;; * feed F contains E
-; ;; * entry E references topic fragment TF
-; ;; * Let LTM be the local topic map
-; ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
-; ;; * For all names, occurrences and associations in which T plays a role, TMC
-; ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC
-; ;; * Merge in the fragment TF using SP as the base all generated source locators.
-;
-; (when
-; (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top))
-; (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator))
-; (names top))
-; (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator))
-; (occurrences top))
-; (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator))
-; (find-associations-for-topic top))
-; (call-next-method)))
-
(defgeneric add-source-locator (construct &key source-locator revision)
(:documentation "adds an item identifier to a given construct based on the source
-locator and an internally generated id (ideally a uuid)"))
+ locator and an internally generated id (ideally a uuid)"))
(defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision)
(declare (ignorable revision))
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Thu Apr 22 06:51:39 2010
@@ -839,6 +839,15 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric mark-as-deleted (construct &key source-locator revision)
+ (:documentation "Mark a construct as deleted if it comes from the source
+ indicated by source-locator"))
+
+
+(defgeneric marked-as-deleted-p (construct)
+ (:documentation "Returns t if the construct was marked-as-deleted."))
+
+
(defgeneric find-self-or-equal (construct parent-construct &key revision)
(:documentation "Returns the construct 'construct' if is owned by the
parent-construct or an equal construct or nil if there
@@ -875,11 +884,6 @@
Variants are deleted from names by calling delete-variant."))
-(defgeneric mark-as-deleted (construct &key source-locator revision)
- (:documentation "Mark a construct as deleted if it comes from the source
- indicated by source-locator"))
-
-
(defgeneric find-oldest-construct (construct-1 construct-2)
(:documentation "Returns the construct which owns the oldes version info.
If a construct is not a versioned construct the oldest
@@ -1089,14 +1093,11 @@
:versioned-construct construct))))))))
-(defgeneric marked-as-deleted-p (construct)
- (:documentation "Returns t if the construct was marked-as-deleted.")
- (:method ((construct VersionedConstructC))
- (if (find-if #'(lambda(vi)
+(defmethod marked-as-deleted-p ((construct VersionedConstructC))
+ (unless (find-if #'(lambda(vi)
(= (end-revision vi) 0))
(versions construct))
- nil
- t)))
+ t))
(defmethod mark-as-deleted ((construct VersionedConstructC)
@@ -1107,7 +1108,7 @@
(find 0 (versions construct) :key #'end-revision)))
(when last-version
(setf (end-revision last-version) revision))))
-
+
;;; TopicMapconstructC
(defgeneric strictly-equivalent-constructs (construct-1 construct-2
@@ -1146,6 +1147,27 @@
;;; PointerC
+(defmethod mark-as-deleted ((construct PointerC) &key source-locator revision)
+ "Marks the last active relation between a pointer and its parent construct
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (identified-construct construct :revision 0)))
+ (when owner
+ (cond ((typep construct 'PersistentIdC)
+ (delete-psi owner construct :revision revision))
+ ((typep construct 'SubjectLocatorC)
+ (delete-locator owner construct :revision revision))
+ ((typep construct 'ItemIdentifierC)
+ (delete-item-identifier owner construct :revision revision))
+ ((typep construct 'TopicIdentificationC)
+ (delete-topic-identifier owner construct :revision revision))))))
+
+
+(defmethod marked-as-deleted-p ((construct PointerC))
+ (unless (identified-construct construct :revision 0)
+ t))
+
+
(defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC))
(let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
(vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
@@ -1371,6 +1393,44 @@
;;; TopicC
+(defmethod mark-as-deleted :around ((top TopicC)
+ &key (source-locator nil sl-provided-p)
+ revision)
+ "Mark a topic as deleted if it comes from the source indicated by
+ source-locator"
+ ;;Part 1b, 1.4.3.3.1:
+ ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
+ ;; * Let SI be the value of TopicSI element in ATOM entry E
+ ;; * feed F contains E)
+ ;; * entry E references topic fragment TF
+ ;; * Let LTM be the local topic map
+ ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
+ ;; * For all names, occurrences and associations in which T plays a role, TMC
+ ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC
+ ;; * Merge in the fragment TF using SP as the base all generated source locators.
+ (when (or (and (not source-locator) sl-provided-p)
+ (and sl-provided-p
+ (some (lambda (psi) (string-starts-with (uri psi) source-locator))
+ (psis top :revision 0))))
+ (unless sl-provided-p
+ (mapc (lambda(psi)(mark-as-deleted psi :revision revision
+ :source-locator source-locator))
+ (psis top :revision 0)))
+ (mapc (lambda(sl)(mark-as-deleted sl :revision revision
+ :source-locator source-locator))
+ (locators top :revision 0))
+ (mapc (lambda (name) (mark-as-deleted name :revision revision
+ :source-locator source-locator))
+ (names top :revision 0))
+ (mapc (lambda (occ) (mark-as-deleted occ :revision revision
+ :source-locator source-locator))
+ (occurrences top :revision 0))
+ (mapc (lambda (ass) (mark-as-deleted ass :revision revision
+ :source-locator source-locator))
+ (find-all-associations-for-topic top :revision 0))
+ (call-next-method)))
+
+
(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC)
&key (revision *TM-REVISION*))
(declare (integer revision))
@@ -2022,6 +2082,20 @@
;;; CharacteristicC
+(defmethod mark-as-deleted ((construct CharacteristicC) &key source-locator revision)
+ "Marks the last active relation between a characteristic and its parent topic
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (parent construct :revision 0)))
+ (when owner
+ (delete-characteristic owner construct :revision revision))))
+
+
+(defmethod marked-as-deleted-p ((construct CharacteristicC))
+ (unless (parent construct :revision 0)
+ t))
+
+
(defmethod find-self-or-equal ((construct CharacteristicC)
(parent-construct TopicC)
&key (revision *TM-REVISION*))
@@ -2405,6 +2479,14 @@
;;; AssociationC
+(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
+ "Marks an association and its roles as deleted"
+ (mapc (lambda (role)
+ (mark-as-deleted role :revision revision :source-locator source-locator))
+ (roles ass :revision 0))
+ (call-next-method))
+
+
(defmethod equivalent-constructs ((construct-1 AssociationC)
(construct-2 AssociationC)
&key (revision *TM-REVISION*))
@@ -2527,6 +2609,20 @@
;;; RoleC
+(defmethod mark-as-deleted ((construct RoleC) &key source-locator revision)
+ "Marks the last active relation between a role and its parent association
+ as deleted."
+ (declare (ignorable source-locator))
+ (let ((owner (parent construct :revision 0)))
+ (when owner
+ (delete-role owner construct :revision revision))))
+
+
+(defmethod marked-as-deleted-p ((construct RoleC))
+ (unless (parent construct :revision 0)
+ t))
+
+
(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC)
&key (revision *TM-REVISION*))
(declare (integer revision))
@@ -2771,6 +2867,15 @@
;;; ReifiableConstructC
+(defmethod mark-as-deleted :around ((construct ReifiableConstructC)
+ &key source-locator revision)
+ "Marks all item-identifiers of a given reifiable-construct as deleted."
+ (declare (ignorable source-locator))
+ (call-next-method)
+ (dolist (ii (item-identifiers construct :revision 0))
+ (delete-item-identifier construct ii :revision revision)))
+
+
(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)
&key (revision *TM-REVISION*))
(declare (integer revision))
@@ -3739,7 +3844,7 @@
(declare (integer revision))
(let ((occs-to-move (occurrences source :revision revision)))
(dolist (occ occs-to-move)
- (delete-occurrence occ source :revision revision)
+ (delete-occurrence source occ :revision revision)
(let ((equivalent-occ
(find-if #'(lambda (destination-occ)
(when
@@ -3847,7 +3952,7 @@
(move-referenced-constructs newer-topic older-topic :revision revision)
(move-reified-construct newer-topic older-topic :revision revision)
(merge-changed-constructs older-topic :revision revision)
- (mark-as-deleted newer-topic :revision revision)
+ (mark-as-deleted newer-topic :revision revision :source-locator nil)
(when (exist-in-revision-history-? newer-topic)
(delete-construct newer-topic))
older-topic))))
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 Thu Apr 22 06:51:39 2010
@@ -81,10 +81,11 @@
:test-find-oldest-construct
:test-move-referenced-constructs-ReifiableConstructC
:test-move-referenced-constructs-NameC
- :test-move-referenced-constructs-TopicC))
+ :test-merge-constructs-TopicC-1))
;;TODO: test merge-constructs
+;;TODO: test mark-as-deleted
@@ -2932,13 +2933,15 @@
(variants name-2 :revision rev-2)))))))))
-(test test-move-referenced-constructs-TopicC ()
+(test test-merge-constructs-TopicC-1 ()
"Tests the generic move-referenced-constructs corresponding to TopicC."
(with-fixture with-empty-db (*db-dir*)
(let ((rev-1 100)
- (rev-2 200))
+ (rev-2 200)
+ (rev-3 300))
(let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+ (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
(sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
(sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
@@ -2956,7 +2959,7 @@
:charvalue "var-1"
:themes (list theme-1)))
(variant-2 (make-construct 'VariantC
- :start-revision rev-1
+ :start-revision rev-2
:charvalue "var-2"
:themes (list theme-2)))
(variant-3 (make-construct 'VariantC
@@ -2973,7 +2976,8 @@
:charvalue "occ-2"
:instance-of type-2))
(occ-3 (make-construct 'OccurrenceC
- :start-revision rev-1
+ :start-revision rev-2
+ :item-identifiers (list ii-3)
:charvalue "occ-1"
:instance-of type-1
:themes (list theme-1))))
@@ -2981,8 +2985,68 @@
:start-revision rev-1
:charvalue "name-1"
:instance-of type-1))
- )
- ))))))
+ (name-2 (make-construct 'NameC
+ :start-revision rev-2
+ :charvalue "name-2"
+ :instance-of type-1
+ :variants (list variant-1 variant-2)))
+ (name-3 (make-construct 'NameC
+ :start-revision rev-1
+ :charvalue "name-1"
+ :instance-of type-1
+ :variants (list variant-3))))
+ (let ((top-1 (make-construct 'TopicC
+ :start-revision rev-1
+ :topic-identifiers (list tid-1)
+ :item-identifiers (list ii-1)
+ :locators (list sl-1)
+ :psis (list psi-1)
+ :names (list name-1 name-2)
+ :occurrences (list occ-1 occ-2)))
+ (top-2 (make-construct 'TopicC
+ :start-revision rev-2
+ :topic-identifiers (list tid-2)
+ :item-identifiers (list ii-2)
+ :locators (list sl-2)
+ :psis (list psi-2)
+ :names (list name-3)
+ :occurrences (list occ-3))))
+ (setf *TM-REVISION* rev-3)
+ (let ((top (d::merge-constructs top-1 top-2 :revision rev-3)))
+ (is (eql top top-1))
+ (is-true (d::marked-as-deleted-p top-2))
+ (is-false (append (psis top-2) (item-identifiers top-2)
+ (locators top-2) (topic-identifiers top-2)
+ (names top-2) (occurrences top-2)))
+ (setf *TM-REVISION* rev-2)
+ (is (= (length (append (psis top-2) (item-identifiers top-2)
+ (locators top-2) (topic-identifiers top-2)
+ (names top-2) (occurrences top-2)))
+ 6))
+ (setf *TM-REVISION* rev-3)
+ (is-false (set-exclusive-or (list ii-1 ii-2)
+ (item-identifiers top-1)))
+ (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1)))
+ (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
+ (is-false (set-exclusive-or (list tid-1 tid-2)
+ (topic-identifiers top-1)))
+ (is-false (set-exclusive-or (list psi-1)
+ (psis top-1 :revision rev-2)))
+ (is-false (set-exclusive-or (list name-1 name-2)
+ (names top-1)))
+ (is-false (set-exclusive-or (variants name-1)
+ (list variant-3)))
+ (is-false (variants name-3))
+ (is-false (set-exclusive-or (occurrences top-1)
+ (list occ-1 occ-2)))
+ (is-false (set-exclusive-or (item-identifiers occ-1)
+ (list ii-3)))
+ (is-false (item-identifiers occ-3))
+ (is-true (d::marked-as-deleted-p name-3))
+ (is-true (d::marked-as-deleted-p occ-3))))))))))
+
+
+
(defun run-datamodel-tests()
@@ -3043,5 +3107,5 @@
(it.bese.fiveam:run! 'test-find-oldest-construct)
(it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
(it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
- (it.bese.fiveam:run! 'test-move-referenced-constructs-TopicC)
+ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list