isidorus-cvs

isidorus-cvs@common-lisp.net

1037 discussions

[isidorus-cvs] r294 - trunk/src/json
by Lukas Giessmann 25 May '10

25 May '10

Author: lgiessmann Date: Tue May 25 13:04:57 2010 New Revision: 294 Log: fixed a compilation problem in the json-importer with sbcl 1.0.34.0.debian Modified: trunk/src/json/json_importer.lisp Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Tue May 25 13:04:57 2010 @@ -242,8 +242,8 @@ (json-to-scope (getf json-decoded-list :scopes))) (instance-of (psis-to-topic (getf json-decoded-list :type)))) - (declare (list json-decoded-list)) - (declare (TopicC top)) + ;(declare (list json-decoded-list)) causes problems with sbcl 1.0.34.0.debian + ;(declare (TopicC top)) (unless namevalue (error "A name must have exactly one namevalue")) (let ((name (make-construct 'NameC

1 0

[isidorus-cvs] r293 - branches/new-datamodel/src/model
by Lukas Giessmann 02 May '10

02 May '10

Author: lgiessmann Date: Sun May 2 08:00:41 2010 New Revision: 293 Log: new-datamodel: added helper-functions for creating conditions; modified all delete-<xy> methods, so the parents are now recursively added to the version-history; added to every delete-<xy> function a private one that does the same operation except adding the parent to the version history --> is needed for merging => to avoid mismatches of the versions; adapted changes.lisp except the method "changed-p" to the new datamodel Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Sun May 2 08:00:41 2010 @@ -21,6 +21,7 @@ (pushnew (start-revision vi) revision-set)) (sort revision-set #'<))) + (defun get-all-revisions-for-tm (tm-id) "Returns an ordered set of the start dates of all revisions in the engine for this Topic Map" @@ -50,7 +51,7 @@ (d:identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri - "http://psi.topicmaps.org/iso13250/model/type-instance")))) + constants:*type-instance-psi*)))) (remove-if #'(lambda(assoc) (when (eql (instance-of assoc :revision revision) @@ -59,41 +60,50 @@ (find-all-associations-for-topic top :revision revision)))) -(defgeneric find-referenced-topics (construct) +(defgeneric find-referenced-topics (construct &key revision) (:documentation "find all the topics that are references from this construct as type, scope or player, as the case may be")) -(defmethod find-referenced-topics ((characteristic CharacteristicC)) - "characteristics are scopable + typable" + +(defmethod find-referenced-topics ((characteristic CharacteristicC) + &key (revision *TM-REVISION*)) + "characteristics are scopable + typable + reifiable" (append - (when (reifier characteristic) - (list (reifier characteristic))) - (themes characteristic) - (when (instance-of-p characteristic) - (list (instance-of characteristic))) + (when (reifier characteristic :revision revision) + (list (reifier characteristic :revision revision))) + (themes characteristic :revision revision) + (when (instance-of-p characteristic :revision revision) + (list (instance-of characteristic :revision revision))) (when (and (typep characteristic 'OccurrenceC) (> (length (charvalue characteristic)) 0) (eq #\# (elt (charvalue characteristic) 0))) - (list (get-item-by-id (subseq (charvalue characteristic) 1)))))) + (list (get-item-by-id (subseq (charvalue characteristic) 1) + :revision revision))))) -(defmethod find-referenced-topics ((role RoleC)) +(defmethod find-referenced-topics ((role RoleC) + &key (revision *TM-REVISION*)) (append - (when (reifier role) - (list (reifier role))) - (list (instance-of role)) - (list (player role)))) + (when (reifier role :revision revision) + (list (reifier role :revision revision))) + (list (instance-of role :revision revision)) + (list (player role :revision revision)))) + -(defmethod find-referenced-topics ((association AssociationC)) +(defmethod find-referenced-topics ((association AssociationC) + &key (revision *TM-REVISION*)) "associations are scopable + typable" (append - (when (reifier association) - (list (reifier association))) - (list (instance-of association)) - (themes association) - (mapcan #'find-referenced-topics (roles association)))) + (when (reifier association :revision revision) + (list (reifier association :revision revision))) + (list (instance-of association :revision revision)) + (themes association :revision revision) + (mapcan #'(lambda(role) + (find-referenced-topics role :revision revision)) + (roles association :revision revision)))) -(defmethod find-referenced-topics ((top TopicC)) +(defmethod find-referenced-topics ((top TopicC) + &key (revision *TM-REVISION*)) "Part 1b of the eGov-Share spec states: # for each topicname in T export a topic stub for each scope topic # for each occurrence in T export a topic stub for the occurrence type (if it exists) @@ -106,11 +116,19 @@ (remove top (append - (list-instanceOf top) - (mapcan #'find-referenced-topics (names top)) - (mapcan #'find-referenced-topics (mapcan #'variants (names top))) - (mapcan #'find-referenced-topics (occurrences top)) - (mapcan #'find-referenced-topics (find-associations-for-topic top)))))) + (list-instanceOf top :revision revision) + (mapcan #'(lambda(name) + (find-referenced-topics name :revision revision)) + (names top :revision revision)) + (mapcan #'(lambda(variant) + (find-referenced-topics variant :revision revision)) + (mapcan #'variants (names top :revision revision))) + (mapcan #'(lambda(occ) + (find-referenced-topics occ :revision revision)) + (occurrences top :revision revision)) + (mapcan #'(lambda(assoc) + (find-referenced-topics assoc :revision revision)) + (find-associations-for-topic top :revision revision)))))) (defgeneric changed-p (construct revision) @@ -204,8 +222,8 @@ (when (changed-p top revision) (make-instance 'FragmentC :revision revision - :associations (find-associations-for-topic top) ;TODO: this quite probably introduces code duplication with query: Check! - :referenced-topics (find-referenced-topics top) + :associations (find-associations-for-topic top :revision revision) ;TODO: this quite probably introduces code duplication with query: Check! + :referenced-topics (find-referenced-topics top :revision revision) :topic top))) (elephant:get-instances-by-class 'TopicC)))))) @@ -220,31 +238,37 @@ (:documentation "adds an item identifier to a given construct based on the source locator and an internally generated id (ideally a uuid)")) + (defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision) - (declare (ignorable revision)) + (declare (integer revision)) (unless - (some (lambda (ii) (string-starts-with (uri ii) source-locator)) (item-identifiers construct)) + (some (lambda (ii) + (string-starts-with (uri ii) source-locator)) + (item-identifiers construct :revision revision)) (let ((ii-uri (format nil "~a/~d" source-locator (internal-id construct)))) - (make-instance 'ItemIdentifierC :uri ii-uri :identified-construct construct :start-revision revision)))) + (make-construct 'ItemIdentifierC + :uri ii-uri + :identified-construct construct + :start-revision revision)))) + (defmethod add-source-locator ((top TopicC) &key source-locator revision) ;topics already have the source locator in (at least) one PSI, so we ;do not need to add an extra item identifier to them. However, we ;need to do that for all their characteristics + associations (mapc (lambda (name) (add-source-locator name :revision revision :source-locator source-locator)) - (names top)) + (names top :revision revision)) (mapc (lambda (occ) (add-source-locator occ :revision revision :source-locator source-locator)) - (occurrences top)) + (occurrences top :revision revision)) (mapc (lambda (ass) (add-source-locator ass :revision revision :source-locator source-locator)) - (find-associations-for-topic top))) + (find-associations-for-topic top :revision revision))) (defun create-latest-fragment-of-topic (topic-psi) "Returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) - (let ((topic - (get-item-by-psi topic-psi))) + (let ((topic (get-latest-topic-by-psi topic-psi))) (when topic (let ((start-revision (start-revision @@ -269,8 +293,7 @@ (defun get-latest-fragment-of-topic (topic-psi) "Returns the latest existing fragment of the passed topic-psi." (declare (string topic-psi)) - (let ((topic - (get-item-by-psi topic-psi))) + (let ((topic (get-latest-topic-by-psi topic-psi))) (when topic (let ((existing-fragments (elephant:get-instances-by-value 'FragmentC 'topic topic))) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun May 2 08:00:41 2010 @@ -160,8 +160,7 @@ (in-package :datamodel) -;;TODO: remove-<xy> --> add to version history??? -;;TODO: adapt changes-lisp +;;TODO: adapt changes.lisp --> changed-p ;;TODO: implement a macro with-merge-constructs, that merges constructs ;; after all operations in the body were called @@ -251,11 +250,7 @@ :accessor uri :inherit t :type string - :initform (error - (make-condition 'missing-argument-error - :message "From PointerC(): uri must be set for a pointer" - :argument-symbol 'uri - :function-symbol ':uri)) + :initform (error (make-missing-argument-condition "From PointerC(): uri must be set for a pointer" 'uri ':uri)) :index t :documentation "The actual value of a pointer, i.e. uri or ID.") (identified-construct :associate (PointerAssociationC identifier) @@ -275,11 +270,7 @@ ((xtm-id :initarg :xtm-id :accessor xtm-id :type string - :initform (error - (make-condition 'missing-argument-error - :message "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier" - :argument-symbol 'xtm-id - :function-symbol ':xtm-id)) + :initform (error (make-missing-argument-condition "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier" 'xtm-id ':xtm-id)) :index t :documentation "ID of the TM this identification came from.")) (:index t) @@ -437,21 +428,13 @@ (defpclass TypeAssociationC(VersionedAssociationC) ((type-topic :initarg :type-topic :accessor type-topic - :initform (error - (make-condition 'missing-argument-error - :message "From TypeAssociationC(): type-topic must be set" - :argument-symbol 'type-topic - :function-symbol ':type-topic)) + :initform (error (make-missing-argument-condition "From TypeAssociationC(): type-topic must be set" 'type-topic ':type-topic)) :associate TopicC :documentation "Associates this object with a topic that is used as type.") (typable-construct :initarg :typable-construct :accessor typable-construct - :initform (error - (make-condition 'missing-argument-error - :message "From TypeAssociationC(): typable-construct must be set" - :argument-symbol 'typable-construct - :function-symbol ':typable-construct)) + :initform (error (make-missing-argument-condition "From TypeAssociationC(): typable-construct must be set" 'typable-construct ':typable-construct)) :associate TypableC :documentation "Associates this object with the typable construct that is typed by the @@ -464,21 +447,13 @@ (defpclass ScopeAssociationC(VersionedAssociationC) ((theme-topic :initarg :theme-topic :accessor theme-topic - :initform (error - (make-condition 'missing-argument-error - :message "From ScopeAssociationC(): theme-topic must be set" - :argument-symbol 'theme-topic - :function-symbol ':theme-topic)) + :initform (error (make-missing-argument-condition "From ScopeAssociationC(): theme-topic must be set" 'theme-topic ':theme-topic)) :associate TopicC :documentation "Associates this opbject with a topic that is a scopable construct.") (scopable-construct :initarg :scopable-construct :accessor scopable-construct - :initform (error - (make-condition 'missing-argument-error - :message "From ScopeAssociationC(): scopable-construct must be set" - :argument-symbol 'scopable-construct - :function-symbol ':scopable-construct)) + :initform (error (make-missing-argument-condition "From ScopeAssociationC(): scopable-construct must be set" 'scopable-construct ':scopable-construct)) :associate ScopableC :documentation "Associates this object with the socpable construct that is scoped by the @@ -491,21 +466,13 @@ (defpclass ReifierAssociationC(VersionedAssociationC) ((reifiable-construct :initarg :reifiable-construct :accessor reifiable-construct - :initform (error - (make-condition 'missing-argument-error - :message "From ReifierAssociation(): reifiable-construct must be set" - :argument-symbol 'reifiable-construct - :function-symbol ':reifiable-construct)) + :initform (error (make-missing-argument-condition "From ReifierAssociation(): reifiable-construct must be set" 'reifiable-construct ':reifiable-construct)) :associate ReifiableConstructC :documentation "The actual construct which is reified by a topic.") (reifier-topic :initarg :reifier-topic :accessor reifier-topic - :initform (error - (make-condition 'missing-argument-error - :message "From ReifierAssociationC(): reifier-topic must be set" - :argument-symbol 'reifier-topic - :function-symbol ':reifier-topic)) + :initform (error (make-missing-argument-condition "From ReifierAssociationC(): reifier-topic must be set" 'reifier-topic ':reifier-topic)) :associate TopicC :documentation "The reifier-topic that reifies the reifiable-construct.")) @@ -518,11 +485,7 @@ ((identifier :initarg :identifier :accessor identifier :inherit t - :initform (error - (make-condition 'missing-argument-error - :message "From PointerAssociationC(): identifier must be set" - :argument-symbol 'identifier - :function-symbol ':identifier)) + :initform (error (make-missing-argument-condition "From PointerAssociationC(): identifier must be set" 'identifier ':identifier)) :associate PointerC :documentation "The actual data that is associated with the pointer-association's parent.")) @@ -533,11 +496,7 @@ (defpclass SubjectLocatorAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error - (make-condition 'missing-argument-error - :message "From SubjectLocatorAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-symbol)) + :initform (error (make-missing-argument-condition "From SubjectLocatorAssociationC(): parent-construct must be set" 'parent-construct ':parent-symbol)) :associate TopicC :documentation "The actual topic which is associated with the subject-locator.")) @@ -548,11 +507,7 @@ (defpclass PersistentIdAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error - (make-condition 'missing-argument-error - :message "From PersistentIdAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From PersistentIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :associate TopicC :documentation "The actual topic which is associated with the subject-identifier/psi.")) @@ -563,11 +518,7 @@ (defpclass TopicIdAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error - (make-condition 'missing-arguement-error - :message "From TopicIdAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From TopicIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :associate TopicC :documentation "The actual topic which is associated with the topic-identifier.")) @@ -578,11 +529,7 @@ (defpclass ItemIdAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error - (make-condition 'missing-argument-error - :message "From ItemIdAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From ItemIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :associate ReifiableConstructC :documentation "The actual parent which is associated with the item-identifier.")) @@ -595,11 +542,7 @@ ((characteristic :initarg :characteristic :accessor characteristic :inherit t - :initform (error - (make-condition 'missing-argument-error - :message "From CharacteristicCAssociation(): characteristic must be set" - :argument-symbol 'characteristic - :function-symbol ':characteristic)) + :initform (error (make-missing-argument-condition "From CharacteristicCAssociation(): characteristic must be set" 'characteristic ':characteristic)) :associate CharacteristicC :documentation "Associates this object with the actual characteristic object.")) @@ -610,11 +553,7 @@ (defpclass VariantAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error - (make-condition 'missing-argument-error - :message "From VariantAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From VariantAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :associate NameC :documentation "Associates this object with a name.")) (:documentation "Associates variant objects with name obejcts. @@ -624,11 +563,7 @@ (defpclass NameAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error - (make-condition 'missing-argument-error - :message "From NameAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From NameAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :associate TopicC :documentation "Associates this object with a topic.")) (:documentation "Associates name objects with their parent topics. @@ -638,11 +573,7 @@ (defpclass OccurrenceAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct - :initform (error - (make-condition 'missing-argument-error - :message "From OccurrenceAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From OccurrenceAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :associate TopicC :documentation "Associates this object with a topic.")) (:documentation "Associates occurrence objects with their parent topics. @@ -654,21 +585,13 @@ ((player-topic :initarg :player-topic :accessor player-topic :associate TopicC - :initform (error - (make-condition 'missing-argument-error - :message "From PlayerAssociationC(): player-topic must be set" - :argument-symbol 'player-topic - :function-symbol ':player-topic)) + :initform (error (make-missing-argument-condition "From PlayerAssociationC(): player-topic must be set" 'player-topic ':player-topic)) :documentation "Associates this object with a topic that is a player.") (parent-construct :initarg :parent-construct :accessor parent-construct :associate RoleC - :initform (error - (make-condition 'missing-argument-error - :message "From PlayerAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From PlayerAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :documentation "Associates this object with the parent-association.")) (:documentation "This class associates roles and their player in given revisions.")) @@ -678,20 +601,12 @@ ((role :initarg :role :accessor role :associate RoleC - :initform (error - (make-condition 'missing-argument-error - :message "From RoleAssociationC(): role must be set" - :argument-symbol 'role - :function-symbol ':role)) + :initform (error (make-missing-argument-condition "From RoleAssociationC(): role must be set" 'role ':role)) :documentation "Associates this objetc with a role-object.") (parent-construct :initarg :parent-construct :accessor parent-construct :associate AssociationC - :initform (error - (make-condition 'missing-argument-error - :message "From RoleAssociationC(): parent-construct must be set" - :argument-symbol 'parent-construct - :function-symbol ':parent-construct)) + :initform (error (make-missing-argument-condition "From RoleAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) :documentation "Assocates thius object with an association-object.")) (:documentation "Associates roles with assoications and adds some @@ -699,6 +614,83 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun make-duplicate-identifier-condition (message uri) + "Returns an duplicate-identifier-condition with the passed arguments." + (make-condition 'duplicate-identifier-error + :message message + :uri uri)) + + +(defun make-object-not-found-condition (message) + "Returns an object-not-found-condition with the passed arguments." + (make-condition 'object-not-found-error + :message message)) + + +(defun make-tm-reference-condition (message referenced-construct + existing-reference new-reference) + "Returns a tm-reference-condition with the passed arguments." + (make-condition 'tm-reference-error + :message message + :referenced-construct referenced-construct + :existing-reference existing-reference + :new-reference new-reference)) + + +(defun make-not-mergable-condition (message construct-1 construct-2) + "Returns a not-mergable-condition with the passed arguments." + (make-condition 'not-mergable-error + :message message + :construct-1 construct-1 + :construct-2 construct-2)) + + +(defun make-missing-argument-condition (message argument-symbol function-symbol) + "Returns a missing-argument-condition with the passed arguments." + (make-condition 'missing-argument-error + :message message + :argument-symbol argument-symbol + :function-symbol function-symbol)) + + +(defgeneric get-most-recent-versioned-assoc (construct slot-symbol) + (:documentation "Returns the most recent VersionedAssociationC + object.") + (:method ((construct TopicMapConstructC) (slot-symbol Symbol)) + (let ((all-assocs (slot-p construct slot-symbol))) + (let ((zero-assoc + (find-if #'(lambda(assoc) + (= (end-revision + (get-most-recent-version-info assoc)) 0)) + all-assocs))) + (if zero-assoc + zero-assoc + (let ((ordered-assocs + (sort all-assocs + #'(lambda(x y) + (> (end-revision + (get-most-recent-version-info x)) + (end-revision + (get-most-recent-version-info y))))))) + (when ordered-assocs + (first ordered-assocs)))))))) + + +(defun get-latest-topic-by-psi (topic-psi) + "Returns the latest topic bound to the PersistentIdC + object corresponding to the given uri." + (declare (String topic-psi)) + (let ((psi-inst + (elephant:get-instance-by-value + 'PersistentIdC 'uri topic-psi))) + (let ((latest-va + (get-most-recent-versioned-assoc + psi-inst 'identified-construct))) + (when latest-va + (identified-construct + psi-inst :revision (start-revision latest-va)))))) + + (defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) "Returns all instances of the given type and the given revision that are stored in the db." @@ -905,12 +897,18 @@ Variants are added to names by calling add-name.")) -(defgeneric delete-characteristic (construct characteristic &key revision) - (:documentation "Deletes the passed characteristic oif the given topic by +(defgeneric private-delete-characteristic (construct characteristic &key revision) + (:documentation "Deletes the passed characteristic of the given topic by calling delete-name or delete-occurrence. Variants are deleted from names by calling delete-variant.")) +(defgeneric delete-characteristic (construct characteristic &key revision) + (:documentation "See private-delete-characteristic but adds the parent + (if it is a variant also the parent's parent) to the + version history of this call's revision")) + + (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 @@ -925,11 +923,16 @@ with the changeds that are caused by this operation.")) -(defgeneric delete-parent (construct parent-construct &key revision) +(defgeneric parent-delete-parent (construct parent-construct &key revision) (:documentation "Sets the assoication-object between the passed constructs as marded-as-deleted.")) +(defgeneric delete-parent (construct parent-construct &key revision) + (:documentation "See private-delete-parent but adds the parent to + the given version.")) + + (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.")) @@ -1083,14 +1086,37 @@ construct))) +(defun add-version-info(construct start-revision) + "Adds 'construct' to the given version. + If the construct is a VersionedConstructC add-to-version-history + is called directly. Otherwise there is called a corresponding + add-<whatever> method that adds recursively 'construct' to its + parent and so on." + (declare (type (or TopicMapConstructC VersionedConstructC) construct) + (integer start-revision)) + (cond ((typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision start-revision)) + ((typep construct 'VariantC) + (let ((name (parent construct :revision start-revision))) + (when name + (add-variant name construct :revision start-revision) + (let ((top (parent name :revision start-revision))) + (when top + (add-name top name :revision start-revision)))))) + ((typep construct 'CharacteristicC) + (let ((top (parent construct :revision start-revision))) + (when top + (add-characteristic top construct :revision start-revision)))) + ((typep construct 'RoleC) + (let ((assoc (parent construct :revision start-revision))) + (when assoc + (add-role assoc construct :revision start-revision)))))) + + (defgeneric add-to-version-history (construct &key start-revision end-revision) (:documentation "Adds version history to a versioned construct") (:method ((construct VersionedConstructC) - &key (start-revision (error - (make-condition 'missing-argument-error - :message "From add-to-version-history(): start revision must be present" - :argument-symbol 'start-revision - :function-symbol 'add-to-version-history))) + &key (start-revision (error (make-missing-argument-condition "From add-to-version-history(): start revision must be present" 'start-revision 'add-to-version-history))) (end-revision 0)) (let ((eql-version-info (find-if #'(lambda(vi) @@ -1189,13 +1215,13 @@ (let ((owner (identified-construct construct :revision 0))) (when owner (cond ((typep construct 'PersistentIdC) - (delete-psi owner construct :revision revision)) + (private-delete-psi owner construct :revision revision)) ((typep construct 'SubjectLocatorC) - (delete-locator owner construct :revision revision)) + (private-delete-locator owner construct :revision revision)) ((typep construct 'ItemIdentifierC) - (delete-item-identifier owner construct :revision revision)) + (private-delete-item-identifier owner construct :revision revision)) ((typep construct 'TopicIdentificationC) - (delete-topic-identifier owner construct :revision revision)))))) + (private-delete-topic-identifier owner construct :revision revision)))))) (defmethod marked-as-deleted-p ((construct PointerC)) @@ -1562,11 +1588,7 @@ (string= (xtm-id top-id) xtm-id)) (topic-identifiers construct :revision revision)))) (unless possible-identifiers - (error (make-condition - 'object-not-found-error - :message - (format nil "Could not find an object ~a in xtm-id ~a" - construct xtm-id)))) + (error (make-object-not-found-condition (format nil "Could not find an object ~a in xtm-id ~a" construct xtm-id)))) (uri (first possible-identifiers))) (concatenate 'string "t" (write-to-string (internal-id construct)))))) @@ -1616,20 +1638,29 @@ merged-construct)))) -(defgeneric delete-topic-identifier (construct topic-identifier &key revision) +(defgeneric private-delete-topic-identifier + (construct topic-identifier &key revision) (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (topic-identifier TopicIdentificationC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-topic-identifier(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-topic-identifier)))) + &key (revision (error (make-missing-argument-condition "From private-delete-topic-identifier(): revision must be set" 'revision 'private-delete-topic-identifier)))) (let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers) when (eql (identifier ti-assoc) topic-identifier) return ti-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (add-to-version-history construct :start-revision revision)) + construct)))) + + +(defgeneric delete-topic-identifier + (construct topic-identifier &key revision) + (:documentation "See private-delete-topic-identifier but adds the parent + construct to the given version") + (:method ((construct TopicC) (topic-identifier TopicIdentificationC) + &key (revision (error (make-missing-argument-condition "From delete-topic-identifier(): revision must be set" 'revision 'delete-topic-identifier)))) + (when (private-delete-topic-identifier construct topic-identifier + :revision revision) + (add-to-version-history construct :start-revision revision) construct))) @@ -1675,20 +1706,26 @@ merged-construct)))) -(defgeneric delete-psi (construct psi &key revision) +(defgeneric private-delete-psi (construct psi &key revision) (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (psi PersistentIdC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-psi(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-psi)))) + &key (revision (error (make-missing-argument-condition "From private-delete-psi(): revision must be set" 'revision 'private-delete-psi)))) (let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis) when (eql (identifier psi-assoc) psi) return psi-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (add-to-version-history construct :start-revision revision)) + construct)))) + + +(defgeneric delete-psi (construct psi &key revision) + (:documentation "See private-delete-psis but adds the parent to the given + version.") + (:method ((construct TopicC) (psi PersistentIdC) + &key (revision (error (make-missing-argument-condition "From delete-psi(): revision must be set" 'revision 'delete-psi)))) + (when (private-delete-psi construct psi :revision revision) + (add-to-version-history construct :start-revision revision) construct))) @@ -1735,20 +1772,26 @@ merged-construct)))) -(defgeneric delete-locator (construct locator &key revision) +(defgeneric private-delete-locator (construct locator &key revision) (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (locator SubjectLocatorC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-locator(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-locator)))) + &key (revision (error (make-missing-argument-condition "From private-delete-locator(): revision must be set" 'revision 'private-delete-locator)))) (let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators) when (eql (identifier loc-assoc) locator) return loc-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (add-to-version-history construct :start-revision revision)) + construct)))) + + +(defgeneric delete-locator (construct locator &key revision) + (:documentation "See private-delete-locator but add the parent construct + to the given version.") + (:method ((construct TopicC) (locator SubjectLocatorC) + &key (revision (error (make-missing-argument-condition "From delete-locator(): revision must be set" 'revision 'delete-locator)))) + (when (private-delete-locator construct locator :revision revision) + (add-to-version-history construct :start-revision revision) construct))) @@ -1779,12 +1822,9 @@ &key (revision *TM-REVISION*)) (when (and (parent name :revision revision) (not (eql (parent name :revision revision) construct))) - (error (make-condition 'tm-reference-error - :message (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" - name construct (parent name :revision revision)) - :referenced-construct name - :existing-reference (parent name :revision revision) - :new-reference construct))) + (error (make-tm-reference-condition (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" + name construct (parent name :revision revision)) + name (parent name :revision revision) construct))) (if (merge-if-equivalent name construct :revision revision) construct (let ((all-names @@ -1804,20 +1844,26 @@ construct)))) -(defgeneric delete-name (construct name &key revision) +(defgeneric private-delete-name (construct name &key revision) (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (name NameC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-name(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-name)))) + &key (revision (error (make-missing-argument-condition "From private-delete-name(): revision must be set" 'revision 'private-delete-name)))) (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) when (eql (characteristic name-assoc) name) return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (add-to-version-history construct :start-revision revision)) + construct)))) + + +(defgeneric delete-name (construct name &key revision) + (:documentation "See private-delete-name but adds the parent to + the given version.") + (:method ((construct TopicC) (name NameC) + &key (revision (error (make-missing-argument-condition "From delete-name(): revision must be set" 'revision 'delete-name)))) + (when (private-delete-name construct name :revision revision) + (add-to-version-history construct :start-revision revision) construct))) @@ -1840,12 +1886,9 @@ &key (revision *TM-REVISION*)) (when (and (parent occurrence :revision revision) (not (eql (parent occurrence :revision revision) construct))) - (error 'tm-reference-error - :message (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" - occurrence construct (parent occurrence :revision revision)) - :referenced-construct occurrence - :existing-reference (parent occurrence :revision revision) - :new-reference construct)) + (error (make-tm-reference-condition (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" + occurrence construct (parent occurrence :revision revision)) + occurrence (parent occurrence :revision revision) construct))) (if (merge-if-equivalent occurrence construct :revision revision) construct (let ((all-occurrences @@ -1864,20 +1907,26 @@ construct)))) -(defgeneric delete-occurrence (construct occurrence &key revision) +(defgeneric private-delete-occurrence (construct occurrence &key revision) (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct TopicC) (occurrence OccurrenceC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-occurrence(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-construct)))) + &key (revision (error (make-missing-argument-condition "From private-delete-occurrence(): revision must be set" 'revision 'private-delete-occurrence)))) (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) when (eql (characteristic occ-assoc) occurrence) return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (add-to-version-history construct :start-revision revision)) + construct)))) + + +(defgeneric delete-occurrence (construct occurrence &key revision) + (:documentation "See private-delete-occurrence but adds the parent + to the given version history.") + (:method ((construct TopicC) (occurrence OccurrenceC) + &key (revision (error (make-missing-argument-condition "From delete-occurrence(): revision must be set" 'revision 'delete-occurrence)))) + (when (private-delete-occurrence construct occurrence :revision revision) + (add-to-version-history construct :start-revision revision) construct))) @@ -1890,9 +1939,19 @@ (add-occurrence construct characteristic :revision revision))) +(defmethod private-delete-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic)))) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (private-delete-name construct characteristic :revision revision) + (private-delete-occurrence construct characteristic + :revision revision))) + + (defmethod delete-characteristic ((construct TopicC) (characteristic CharacteristicC) - &key (revision *TM-REVISION*)) + &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic)))) (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) (if (typep characteristic 'NameC) (delete-name construct characteristic :revision revision) @@ -1945,11 +2004,22 @@ (add-reifier reified-construct construct :revision revision))) -(defgeneric delete-reified-construct (construct reified-construct &key revision) +(defgeneric private-delete-reified-construct + (construct reified-construct &key revision) (:documentation "Unsets the passed construct as reified-construct of the given topic.") (:method ((construct TopicC) (reified-construct ReifiableConstructC) - &key (revision *TM-REVISION*)) + &key (revision (error (make-missing-argument-condition "From private-delete-reified-construct(): revision must be set" 'revision 'private-delete-reified-construct)))) + (declare (integer revision)) + (private-delete-reifier reified-construct construct + :revision revision))) + + +(defgeneric delete-reified-construct (construct reified-construct &key revision) + (:documentation "See private-delete-reified-construct but adds the + reifier to the given version.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision (error (make-missing-argument-condition "From -delete-reified-construct(): revision must be set" 'revision '-delete-reified-construct)))) (declare (integer revision)) (delete-reifier reified-construct construct :revision revision))) @@ -1984,11 +2054,7 @@ (identified-construct (first possible-top-ids) :revision revision)) (unless (= (length possible-top-ids) 1) - (error - (make-condition 'duplicate-identifier-error - :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" - possible-top-ids topic-id xtm-id) - :uri topic-id))) + (error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" possible-top-ids topic-id xtm-id) topic-id))) (identified-construct (first possible-top-ids) :revision revision) ;no revision need not to be chaecked, since the revision @@ -2004,9 +2070,7 @@ (when (find-item-by-revision top-from-oid revision) top-from-oid)))))) (if (and error-if-nil (not result)) - (error (make-condition 'object-not-found-error - :message (format nil "No such item (id: ~a, tm: ~a, rev: ~a)" - topic-id xtm-id revision))) + (error (make-object-not-found-condition (format nil "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision))) result))) @@ -2025,10 +2089,7 @@ (identified-construct (first possible-ids) :revision revision)) (unless (= (length possible-ids) 1) - (error (make-condition 'duplicate-identifier-error - :message (format nil "(length possible-items ~a) for id ~a" - possible-ids uri) - :uri uri))) + (error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri))) (identified-construct (first possible-ids) :revision revision))))) ;no revision need to be checked, since the revision @@ -2036,8 +2097,7 @@ (if result result (when error-if-nil - (error (make-condition 'object-not-found-error - :message "No such item is bound to the given identifier uri.")))))) + (error (make-object-not-found-condition "No such item is bound to the given identifier uri.")))))) (defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*) @@ -2123,7 +2183,7 @@ (declare (ignorable source-locator)) (let ((owner (parent construct :revision 0))) (when owner - (delete-characteristic owner construct :revision revision)))) + (private-delete-characteristic owner construct :revision revision)))) (defmethod marked-as-deleted-p ((construct CharacteristicC)) @@ -2273,12 +2333,9 @@ return parent-assoc))) (when (and already-set-parent (not (eql already-set-parent parent-construct))) - (error (make-condition 'tm-reference-error - :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" construct parent-construct already-set-parent) - :referenced-construct construct - :existing-reference (parent construct :revision revision) - :new-reference parent-construct))) + construct (parent construct :revision revision) parent-construct))) (let ((merged-char (merge-if-equivalent construct parent-construct :revision revision))) (if merged-char @@ -2311,21 +2368,26 @@ construct))))) -(defmethod delete-parent ((construct CharacteristicC) - (parent-construct ReifiableConstructC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-parent(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-parent)))) +(defmethod private-delete-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent)))) (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) - (when (typep parent-construct 'VersionedConstructC) - (add-to-version-history parent-construct :start-revision revision))) - construct)) + construct))) + + +(defmethod delete-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent)))) + (let ((parent (parent construct :revision revision))) + (when (private-delete-parent construct parent-construct :revision revision) + (when parent + (add-version-info parent revision)) + construct))) ;;; OccurrenceC @@ -2461,12 +2523,9 @@ &key (revision *TM-REVISION*)) (when (and (parent variant :revision revision) (not (eql (parent variant :revision revision) construct))) - (error (make-condition 'tm-reference-error - :message (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" - variant construct (parent variant :revision revision)) - :referenced-construct variant - :existing-reference (parent variant :revision revision) - :new-reference construct))) + (error (make-tm-reference-condition (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" + variant construct (parent variant :revision revision)) + variant (parent variant :revision revision) construct))) (if (merge-if-equivalent variant construct :revision revision) construct (let ((all-variants @@ -2487,21 +2546,30 @@ construct)))) -(defgeneric delete-variant (construct variant &key revision) +(defgeneric private-delete-variant (construct variant &key revision) (:documentation "Deletes the passed variant by marking it's association as deleted in the passed revision.") (:method ((construct NameC) (variant VariantC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-variant(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-variant)))) + &key (revision (error (make-missing-argument-condition "From private-delete-variant(): revision must be set" 'revision 'private-delete-variant)))) (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct 'variants) when (eql (characteristic variant-assoc) variant) return variant-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct))) + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-variant (construct variant &key revision) + (:documentation "See private-delete-variant but adds a the parent + and the parent's parent to the given version history.") + (:method ((construct NameC) (variant VariantC) + &key (revision (error (make-missing-argument-condition "From delete-variant(): revision must be set" 'revision 'delete-variant)))) + (when (private-delete-variant construct variant :revision revision) + (when (parent construct :revision revision) + (add-name (parent construct :revision revision) construct + :revision revision) + construct)))) (defmethod add-characteristic ((construct NameC) (characteristic VariantC) @@ -2510,8 +2578,14 @@ (add-variant construct characteristic :revision revision)) -(defmethod delete-characteristic ((construct NameC) (characteristic VariantC) - &key (revision *TM-REVISION*)) +(defmethod private-delete-characteristic ((construct NameC) (characteristic VariantC) + &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic)))) + (declare (integer revision)) + (private-delete-variant construct characteristic :revision revision)) + + +(defmethod delete-characteristic ((construct NameC) (characteristic VariantC) + &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic)))) (declare (integer revision)) (delete-variant construct characteristic :revision revision)) @@ -2631,20 +2705,26 @@ construct)))) -(defgeneric delete-role (construct role &key revision) +(defgeneric private-delete-role (construct role &key revision) (:documentation "Deletes the passed role by marking it's association as deleted in the passed revision.") (:method ((construct AssociationC) (role RoleC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-role(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-role)))) + &key (revision (error (make-missing-argument-condition "From private-delete-role(): revision must be set" 'revision 'private-delete-role)))) (let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles) when (eql (role role-assoc) role) return role-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (add-to-version-history construct :start-revision revision)) + construct)))) + + +(defgeneric delete-role (construct role &key revision) + (:documentation "See private-delete-role but adds the parent association + to the given version.") + (:method ((construct AssociationC) (role RoleC) + &key (revision (error (make-missing-argument-condition "From delete-role(): revision must be set" 'revision 'delete-role)))) + (when (private-delete-role construct role :revision revision) + (add-to-version-history construct :start-revision revision) construct))) @@ -2659,7 +2739,7 @@ (declare (ignorable source-locator)) (let ((owner (parent construct :revision 0))) (when owner - (delete-role owner construct :revision revision)))) + (private-delete-role owner construct :revision revision)))) (defmethod marked-as-deleted-p ((construct RoleC)) @@ -2803,12 +2883,9 @@ return parent-assoc))) (when (and already-set-parent (not (eql already-set-parent parent-construct))) - (error (make-condition 'tm-reference-error - :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" - construct parent-construct already-set-parent) - :referenced-construct construct - :existing-reference (parent construct :revision revision) - :new-reference parent-construct))) + (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent) + construct (parent construct :revision revision) parent-construct))) (let ((merged-role (merge-if-equivalent construct parent-construct :revision revision))) (if merged-role @@ -2834,18 +2911,21 @@ construct))))) -(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-parent(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-parent)))) +(defmethod private-delete-parent ((construct RoleC) (parent-construct AssociationC) + &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent)))) (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) - (add-to-version-history parent-construct :start-revision revision)) + construct))) + + +(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) + &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent)))) + (when (private-delete-parent construct parent-construct :revision revision) + (add-to-version-history parent-construct :start-revision revision) construct)) @@ -2871,12 +2951,8 @@ return player-assoc))) (when (and already-set-player (not (eql already-set-player player-topic))) - (error (make-condition 'tm-reference-error - :message (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a" - construct player-topic already-set-player) - :referenced-construct construct - :existing-reference (player construct :revision revision) - :new-reference player-topic))) + (error (make-tm-reference-condition (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a" construct player-topic already-set-player) + construct (player construct :revision revision) player-topic))) (cond (already-set-player (let ((player-assoc (loop for player-assoc in (slot-p construct 'player) @@ -2893,21 +2969,30 @@ construct)) -(defgeneric delete-player (construct player-topic &key revision) +(defgeneric private-delete-player (construct player-topic &key revision) (:documentation "Deletes the passed topic as a player of the passed role object by marking its association-object as deleted.") (:method ((construct RoleC) (player-topic TopicC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-parent(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-player)))) + &key (revision (error (make-missing-argument-condition "From private-delete-player(): revision must be set" 'revision 'private-delete-player)))) (let ((assoc-to-delete (loop for player-assoc in (slot-p construct 'player) when (eql (parent-construct player-assoc) construct) return player-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct))) + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-player (construct player-topic &key revision) + (:documentation "See delete-player but adds the parent role to + the given version.") + (:method ((construct RoleC) (player-topic TopicC) + &key (revision (error (make-missing-argument-condition "From delete-player(): revision must be set" 'revision 'delete-player)))) + (when (private-delete-player construct player-topic :revision revision) + (let ((assoc (parent construct :revision revision))) + (when assoc + (add-role assoc construct :revision revision) + construct))))) ;;; ReifiableConstructC @@ -2917,7 +3002,7 @@ (declare (ignorable source-locator)) (call-next-method) (dolist (ii (item-identifiers construct :revision 0)) - (delete-item-identifier construct ii :revision revision))) + (private-delete-item-identifier construct ii :revision revision))) (defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC) @@ -2932,10 +3017,7 @@ (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id)) (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id))))) 1) - (error - (make-condition 'duplicate-identifier-error - :message (format nil "Duplicate Identifier ~a has been found" (uri id)) - :uri (uri id)))))) + (error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id)))))) (defgeneric ReifiableConstructC-p (class-symbol) @@ -3047,34 +3129,33 @@ :parent-construct construct :identifier item-identifier :start-revision revision))) - (cond ((typep merged-construct 'VersionedConstructC) - (add-to-version-history merged-construct :start-revision revision)) - ((and (typep merged-construct 'CharacteristicC) - (parent merged-construct :revision revision)) - (add-characteristic (parent merged-construct :revision revision) - merged-construct :revision revision)) - ((and (typep merged-construct 'RoleC) - (parent merged-construct :revision revision)) - (add-role (parent merged-construct :revision revision) - merged-construct :revision revision))) + (add-version-info construct revision) merged-construct)))) -(defgeneric delete-item-identifier (construct item-identifier &key revision) +(defgeneric private-delete-item-identifier (construct item-identifier + &key revision) (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-item-identifier(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-item-identifier)))) + &key (revision (error (make-missing-argument-condition "From private-delete-item-identifier(): revision must be set" 'revision 'private-delete-item-identifier)))) (let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers) when (eql (identifier ii-assoc) item-identifier) return ii-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (when (typep construct 'VersionedConstructC) - (add-to-version-history construct :start-revision revision))) + construct)))) + + +(defgeneric delete-item-identifier (construct item-identifier + &key revision) + (:documentation "See private-delete-item-identifier but adds the parent + construct to the given version.") + (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) + &key (revision (error (make-missing-argument-condition "From delete-item-identifier(): revision must be set" 'revision 'delete-item-identifier)))) + (when (private-delete-item-identifier construct item-identifier + :revision revision) + (add-version-info construct revision) construct))) @@ -3090,11 +3171,9 @@ (not (equivalent-constructs construct (reified-construct reifier-topic :revision revision)))) - (error (make-condition 'not-mergable-error - :message (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable" - reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct) - :construct-1 construct - :construct-2 (reified-construct reifier-topic :revision revision)))) + (error (make-not-mergable-condition (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable" + reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct) + construct (reified-construct reifier-topic :revision revision)))) (let ((merged-reifier-topic (if (reifier construct :revision revision) (merge-constructs (reifier construct :revision revision) @@ -3123,26 +3202,30 @@ :reifiable-construct construct :reifier-topic merged-reifier-topic :start-revision revision))) - (when (typep construct 'VersionedConstructC) - (add-to-version-history merged-construct :start-revision revision)) + (add-version-info construct revision) merged-construct))))) -(defgeneric delete-reifier (construct reifier &key revision) +(defgeneric private-delete-reifier (construct reifier &key revision) (:documentation "Sets the association object between the passed constructs as mark-as-deleted.") (:method ((construct ReifiableConstructC) (reifier TopicC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-reifier(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-reifier)))) + &key (revision (error (make-missing-argument-condition "From private-delete-reifier(): revision must be set" 'revision 'private-delete-reifier)))) (let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier) when (eql (reifier-topic reifier-assoc) reifier) return reifier-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision) - (when (typep construct 'VersionedConstructC) - (add-to-version-history construct :start-revision revision))) + construct)))) + + +(defgeneric delete-reifier (construct reifier &key revision) + (:documentation "See private-delete-reifier but adds the reified-construct + to the given version.") + (:method ((construct ReifiableConstructC) (reifier TopicC) + &key (revision (error (make-missing-argument-condition "From delete-reifier(): revision must be set" 'revision 'delete-reifier)))) + (when (private-delete-reifier construct reifier :revision revision) + (add-version-info construct revision) construct))) @@ -3249,21 +3332,26 @@ construct)) -(defgeneric delete-theme (construct theme-topic &key revision) +(defgeneric private-delete-theme (construct theme-topic &key revision) (:documentation "Deletes the passed theme by marking it's association as deleted in the passed revision.") (:method ((construct ScopableC) (theme-topic TopicC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-theme(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-theme)))) + &key (revision (error (make-missing-argument-condition "From private-delete-theme(): revision must be set" 'revision 'private-delete-theme)))) (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes) when (eql (theme-topic theme-assoc) theme-topic) return theme-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (when (typep construct 'VersionedConstructC) - (add-to-version-history construct :start-revision revision)) + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-theme (construct theme-topic &key revision) + (:documentation "See private-delete-theme but adds the parent construct + to the given version.") + (:method ((construct ScopableC) (theme-topic TopicC) + &key (revision (error (make-missing-argument-condition "From delete-theme(): revision must be set" 'revision 'delete-theme)))) + (when (private-delete-theme construct theme-topic :revision revision) + (add-version-info construct revision) construct))) @@ -3305,12 +3393,9 @@ return type-assoc))) (when (and already-set-type (not (eql type-topic already-set-type))) - (error (make-condition 'tm-reference-error - :message (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a" - construct type-topic already-set-type) - :referenced-construct construct - :existing-reference (instance-of construct :revision revision) - :new-reference type-topic))) + (error (make-tm-reference-condition (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a" + construct type-topic already-set-type) + construct (instance-of construct :revision revision) type-topic))) (cond (already-set-type (let ((type-assoc (loop for type-assoc in (slot-p construct 'instance-of) @@ -3329,22 +3414,27 @@ construct)) -(defgeneric delete-type (construct type-topic &key revision) +(defgeneric private-delete-type (construct type-topic &key revision) (:documentation "Deletes the passed type by marking it's association as deleted in the passed revision.") (:method ((construct TypableC) (type-topic TopicC) - &key (revision (error (make-condition 'missing-argument-error - :message "From delete-type(): revision must be set" - :argument-symbol 'revision - :function-symbol 'delete-type)))) + &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type)))) (let ((assoc-to-delete (loop for type-assoc in (slot-p construct 'instance-of) when (eql (type-topic type-assoc) type-topic) return type-assoc))) (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - (when (typep construct 'VersionedConstructC) - (add-to-version-history construct :start-revision revision)) + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-type (construct type-topic &key revision) + (:documentation "See private-delete-type but adds the parent construct + to the given version.") + (:method ((construct TypableC) (type-topic TopicC) + &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type)))) + (when (private-delete-type construct type-topic :revision revision) + (add-version-info construct revision) construct))) @@ -3425,10 +3515,7 @@ (and (ReifiableConstructC-p class-symbol) (or (getf args :item-identifiers) (getf args :reifier)))) (not (getf args :start-revision))) - (error (make-condition 'missing-argument-error - :message "From make-construct(): start-revision must be set" - :argument-symbol 'start-revision - :function-symbol 'make-construct))) + (error (make-missing-argument-condition "From make-construct(): start-revision must be set" 'start-revision 'make-construct))) (let ((construct (cond ((PointerC-p class-symbol) @@ -3476,10 +3563,7 @@ (roles (getf args :roles))) (when (and (or roles instance-of themes) (not start-revision)) - (error (make-condition 'missing-argument-error - :message "From make-association(): start-revision must be set" - :argument-symbol 'start-revision - :function-symbol 'make-association))) + (error (make-missing-argument-condition "From make-association(): start-revision must be set" 'start-revision 'make-association))) (let ((association (let ((existing-associations (remove-if @@ -3517,10 +3601,7 @@ (start-revision (getf args :start-revision))) (when (and (or instance-of player parent) (not start-revision)) - (error (make-condition 'missing-argument-error - :message "From make-role(): start-revision must be set" - :argument-symbol 'start-revision - :function-symbol 'make-role))) + (error (make-missing-argument-condition "From make-role(): start-revision must be set" 'start-revision 'make-role))) (let ((role (let ((existing-roles (when parent @@ -3562,10 +3643,7 @@ (start-revision (getf args :start-revision))) (when (and (or item-identifiers reifier) (not start-revision)) - (error (make-condition 'missing-argument-error - :message "From make-tm(): start-revision must be set" - :argument-symbol 'start-revision - :function-symbol 'make-tm))) + (error (make-missing-argument-condition "From make-tm(): start-revision must be set" 'start-revision 'make-tm))) (let ((tm (let ((existing-tms (remove-if @@ -3603,10 +3681,7 @@ (when (and (or psis locators item-identifiers topic-identifiers names occurrences) (not start-revision)) - (error (make-condition 'missing-argument-error - :message "From make-topic(): start-revision must be set" - :argument-symbol 'start-revision - :function-symbol 'make-topic))) + (error (make-missing-argument-condition "From make-topic(): start-revision must be set" 'start-revision 'make-topic))) (let ((topic (let ((existing-topics (remove-if @@ -3662,10 +3737,7 @@ (parent (getf args :parent))) (when (and (or instance-of themes variants parent) (not start-revision)) - (error (make-condition 'missing-argument-error - :message "From make-characteristic(): start-revision must be set" - :argument-symbol 'start-revision - :function-symbol 'make-characgteristic))) + (error (make-missing-argument-condition "From make-characteristic(): start-revision must be set" 'start-revision 'make-characgteristic))) (let ((characteristic (let ((existing-characteristics (when parent @@ -3708,21 +3780,12 @@ (identified-construct (getf args :identified-construct)) (err "From make-pointer(): ")) (when (and identified-construct (not start-revision)) - (error (make-condition 'missing-argument-error - :message (format nil "~astart-revision must be set" err) - :argument-symbol 'start-revision - :function-symbol 'make-pointer))) + (error (make-missing-argument-condition (format nil "~astart-revision must be set" err) 'start-revision 'make-pointer))) (unless uri - (error (make-condition 'missing-argument-error - :message (format nil "~auri must be set" err) - :argument-symbol 'uri - :function-symbol 'make-pointer))) + (error (make-missing-argument-condition (format nil "~auri must be set" err) 'uri 'make-pointer))) (when (and (TopicIdentificationC-p class-symbol) (not xtm-id)) - (error (make-condition 'missing-argument-error - :message (format nil "~axtm-id must be set" err) - :argument-symbol 'xtm-id - :function-symbol 'make-pointer))) + (error (make-missing-argument-condition (format nil "~axtm-id must be set" err) 'xtm-id 'make-pointer))) (let ((identifier (let ((existing-pointer (remove-if @@ -3763,7 +3826,7 @@ (declare (integer revision)) (let ((iis (item-identifiers source :revision revision))) (dolist (ii iis) - (delete-item-identifier source ii :revision revision) + (private-delete-item-identifier source ii :revision revision) (add-item-identifier destination ii :revision revision)) iis)) @@ -3776,13 +3839,13 @@ (psis (psis source :revision revision)) (sls (locators source :revision revision))) (dolist (tid tids) - (delete-topic-identifier source tid :revision revision) + (private-delete-topic-identifier source tid :revision revision) (add-topic-identifier destination tid :revision revision)) (dolist (psi psis) - (delete-psi source psi :revision revision) + (private-delete-psi source psi :revision revision) (add-psi destination psi :revision revision)) (dolist (sl sls) - (delete-locator source sl :revision revision) + (private-delete-locator source sl :revision revision) (add-locator destination sl :revision revision)) (append tids iis psis sls))) @@ -3804,10 +3867,10 @@ (destination-reifier (reifier destination :revision revision))) (let ((result (cond ((and source-reifier destination-reifier) - (delete-reifier (reified-construct source-reifier + (private-delete-reifier (reified-construct source-reifier :revision revision) source-reifier :revision revision) - (delete-reifier (reified-construct destination-reifier + (private-delete-reifier (reified-construct destination-reifier :revision revision) destination-reifier :revision revision) (let ((merged-reifier @@ -3816,7 +3879,7 @@ (add-reifier destination merged-reifier :revision revision) merged-reifier)) (source-reifier - (delete-reifier (reified-construct source-reifier + (private-delete-reifier (reified-construct source-reifier :revision revision) source-reifier :revision revision) (add-reifier destination source-reifier :revision revision) @@ -3842,13 +3905,13 @@ (typables (used-as-type source :revision revision)) (ids (move-identifiers source destination :revision revision))) (dolist (role roles) - (delete-player role source :revision revision) + (private-delete-player role source :revision revision) (add-player role destination :revision revision)) (dolist (scopable scopables) - (delete-theme scopable source :revision revision) + (private-delete-theme scopable source :revision revision) (add-theme scopable destination :revision revision)) (dolist (typable typables) - (delete-type typable source :revision revision) + (private-delete-type typable source :revision revision) (add-type typable destination :revision revision)) (remove-if #'null (append roles scopables typables ids)))) @@ -3864,21 +3927,19 @@ (when (and source-reified destination-reified (not (eql (type-of source-reified) (type-of destination-reified)))) - (error (make-condition 'not-mergable-error - :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" - source destination source-reified destination-reified) - :construct-1 source - :construct-2 destination))) + (error (make-not-mergable-condition (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" + source destination source-reified destination-reified) + source destination))) (cond ((and source-reified destination-reified) - (delete-reifier source-reified source :revision revision) - (delete-reifier destination-reified destination :revision revision) + (private-delete-reifier source-reified source :revision revision) + (private-delete-reifier destination-reified destination :revision revision) (let ((merged-reified (merge-constructs source-reified destination-reified :revision revision))) (add-reifier merged-reified destination :revision revision) merged-reified)) (source-reified - (delete-reifier source source-reified :revision revision) + (private-delete-reifier source source-reified :revision revision) (add-reifier source-reified destination :revision revision) source-reified) (destination-reified @@ -3894,7 +3955,7 @@ (declare (integer revision)) (let ((occs-to-move (occurrences source :revision revision))) (dolist (occ occs-to-move) - (delete-occurrence source occ :revision revision) + (private-delete-occurrence source occ :revision revision) (let ((equivalent-occ (find-if #'(lambda (destination-occ) (when @@ -3919,7 +3980,7 @@ (declare (integer revision)) (let ((vars-to-move (variants source :revision revision))) (dolist (var vars-to-move) - (delete-variant source var :revision revision) + (private-delete-variant source var :revision revision) (let ((equivalent-var (find-if #'(lambda (destination-var) (when @@ -3944,7 +4005,7 @@ (declare (integer revision)) (let ((names-to-move (names source :revision revision))) (dolist (name names-to-move) - (delete-name source name :revision revision) + (private-delete-name source name :revision revision) (let ((equivalent-name (find-if #'(lambda (destination-name) (when @@ -4060,15 +4121,12 @@ (parent-2 (parent newer-char :revision revision))) (unless (strictly-equivalent-constructs construct-1 construct-2 :revision revision) - (error (make-condition 'not-mergable-error - :message (format nil "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2) - :construct-1 construct-1 - :construct-2 construct-2))) + (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) + construct-1 construct-2))) (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-char older-char :revision revision) - (delete-characteristic parent-2 newer-char + (private-delete-characteristic parent-2 newer-char :revision revision) (let ((c-assoc (find-if @@ -4158,14 +4216,11 @@ (themes construct-2 :revision revision)) (not (eql (instance-of construct-1 :revision revision) (instance-of construct-2 :revision revision)))) - (error (make-condition 'not-mergable-error - :message (format nil "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2) - :construct-1 construct-1 - :construct-2 construct-2))) + (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) + construct-1 construct-2))) (dolist (tm (in-topicmaps newer-assoc :revision revision)) (add-to-tm tm older-assoc)) - (delete-type newer-assoc (instance-of newer-assoc :revision revision) + (private-delete-type newer-assoc (instance-of newer-assoc :revision revision) :revision revision) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) @@ -4177,7 +4232,7 @@ (when equivalent-role (move-referenced-constructs newer-role equivalent-role :revision revision)) - (delete-role newer-assoc newer-role :revision revision) + (private-delete-role newer-assoc newer-role :revision revision) (add-role older-assoc (if equivalent-role equivalent-role newer-role) @@ -4199,17 +4254,14 @@ construct-1))) (unless (strictly-equivalent-constructs construct-1 construct-2 :revision revision) - (error (make-condition 'not-mergable-error - :message (format nil "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2) - :construct-1 construct-1 - :construct-2 construct-2))) + (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) + construct-1 construct-2))) (let ((parent-1 (parent older-role :revision revision)) (parent-2 (parent newer-role :revision revision))) (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-role older-role :revision revision) - (delete-role parent-2 newer-role :revision revision) + (private-delete-role parent-2 newer-role :revision revision) (let ((r-assoc (find-if #'(lambda(r-assoc)

1 0

[isidorus-cvs] r292 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 29 Apr '10

29 Apr '10

Author: lgiessmann Date: Thu Apr 29 11:07:06 2010 New Revision: 292 Log: new-datamodel: fixed two bugs in "merge-constructs" corresponding to "AssociationC" 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 Thu Apr 29 11:07:06 2010 @@ -4149,8 +4149,15 @@ (let ((newer-assoc (if (eql older-assoc construct-1) construct-2 construct-1))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) + ;(unless (strictly-equivalent-constructs construct-1 construct-2 + ; :revision revision) + ;;associations that have different roles can be although merged, e.g. + ;;two roles are in two different association objects references + ;;the same item-identifier or reifier + (when (or (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision)) + (not (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)))) (error (make-condition 'not-mergable-error :message (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) @@ -4158,6 +4165,8 @@ :construct-2 construct-2))) (dolist (tm (in-topicmaps newer-assoc :revision revision)) (add-to-tm tm older-assoc)) + (delete-type newer-assoc (instance-of newer-assoc :revision revision) + :revision revision) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4165,10 +4174,14 @@ (strictly-equivalent-constructs older-role newer-role :revision revision)) (roles older-assoc :revision revision)))) - (move-referenced-constructs newer-role equivalent-role - :revision revision) + (when equivalent-role + (move-referenced-constructs newer-role equivalent-role + :revision revision)) (delete-role newer-assoc newer-role :revision revision) - (add-role older-assoc equivalent-role :revision revision))) + (add-role older-assoc (if equivalent-role + equivalent-role + newer-role) + :revision revision))) (mark-as-deleted newer-assoc :revision revision) (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) 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 29 11:07:06 2010 @@ -90,7 +90,8 @@ :test-merge-constructs-TopicC-7 :test-merge-constructs-TopicC-8 :test-merge-constructs-TopicC-9 - :test-merge-constructs-TopicC-10)) + :test-merge-constructs-TopicC-10 + :test-merge-constructs-AssociationC)) (declaim (optimize (debug 3))) @@ -2938,7 +2939,7 @@ (test test-merge-constructs-TopicC-1 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3051,7 +3052,7 @@ (test test-merge-constructs-TopicC-2 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3165,7 +3166,7 @@ (test test-merge-constructs-TopicC-3 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3265,7 +3266,7 @@ (test test-merge-constructs-TopicC-4 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3323,7 +3324,7 @@ (test test-merge-constructs-TopicC-5 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3381,7 +3382,7 @@ (test test-merge-constructs-TopicC-6 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3452,7 +3453,7 @@ (test test-merge-constructs-TopicC-7 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3521,7 +3522,7 @@ (test test-merge-constructs-TopicC-8 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3587,7 +3588,7 @@ (test test-merge-constructs-TopicC-9 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3641,7 +3642,7 @@ (test test-merge-constructs-TopicC-10 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3716,12 +3717,82 @@ (is-false (set-exclusive-or (list variant-1) (variants name-1))) (is-false (set-exclusive-or (list variant-2) (variants name-4))) (is (= (length (d::versions top-1)) 2)))))))) - - - -;;TODO: merge associations caused by a merge of their roles +(test test-merge-constructs-AssociationC () + "Tests merge-constructs corresponding to AssociationC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-2 (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (player-2 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-1)) + (role-2-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-2)) + (role-2-2 (list :start-revision rev-2 + :player player-1 + :item-identifiers (list ii-2) + :instance-of r-type-2)) + (role-3 (list :start-revision rev-2 + :player player-2 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :instance-of r-type-2))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :roles (list role-1 role-2-1))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-2-2 role-3)))) + (setf *TM-REVISION* rev-3) + (is (= (length (get-all-associations nil)) 2)) + (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-1 role-2-1)) + (is (= (length (get-all-associations nil)) 2)) + (let ((role-2-1-inst + (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1))) + (roles assoc-1)))) + (is-true role-2-1-inst) + (is (eql (add-item-identifier role-2-1-inst ii-2) role-2-1-inst)) + (is-true (marked-as-deleted-p assoc-2)) + (is-false (roles assoc-2)) + (is-false (instance-of assoc-2)) + (is-false (themes assoc-2)) + (is (eql (instance-of assoc-2 :revision rev-2) type-1)) + (is (= (length (roles assoc-1)) 3)) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-1))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-2) + (not (set-exclusive-or + (list ii-1) + (item-identifiers role))))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1) + (not (set-exclusive-or + (list ii-2) + (item-identifiers role))))) + (roles assoc-1)))))))))) (defun run-datamodel-tests() @@ -3792,4 +3863,4 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10) - ) \ No newline at end of file + (it.bese.fiveam:run! 'test-merge-constructs-AssociationC)) \ No newline at end of file

1 0

[isidorus-cvs] r291 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 29 Apr '10

29 Apr '10

Author: lgiessmann Date: Thu Apr 29 06:47:46 2010 New Revision: 291 Log: new-datamodel: fixed a bug when merging topics by adding an item-identifier to two different variants of the topic's names that are mergable 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 Thu Apr 29 06:47:46 2010 @@ -4101,7 +4101,10 @@ (find older-char (variants name :revision revision))) - (names active-parent :revision revision)))))) + (if (parent active-parent :revision revision) + (names (parent active-parent :revision revision) + :revision revision) + (list active-parent))))))) (if found-older-char older-char newer-char)))) 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 29 06:47:46 2010 @@ -89,13 +89,8 @@ :test-merge-constructs-TopicC-6 :test-merge-constructs-TopicC-7 :test-merge-constructs-TopicC-8 - :test-merge-constructs-TopicC-9)) - - -;;TODO: test merge-constructs --> associations when merge was caused by -;; item-identifier of two roles -;;TODO: test mark-as-deleted - + :test-merge-constructs-TopicC-9 + :test-merge-constructs-TopicC-10)) (declaim (optimize (debug 3))) @@ -3644,8 +3639,87 @@ (is-false (set-exclusive-or (list occ-2) (occurrences top-2)))))))) -;;TODO: merge topics caused by variant-item-identifiers -;;TODO: merge associations caused by a merge of their characteristics + +(test test-merge-constructs-TopicC-10 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list psi-1))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :psis (list psi-2))) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-1 (make-construct 'TopicC :start-revision rev-1))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :instance-of nil + :charvalue "name" + :themes (list scope-1) + :item-identifiers (list ii-1) + :parent top-1)) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :instance-of type-1 + :charvalue "name" + :themes (list scope-1) + :parent top-1)) + (name-3 (make-construct 'NameC + :start-revision rev-2 + :instance-of nil + :charvalue "name" + :themes (list scope-1) + :item-identifiers (list ii-2) + :parent top-2)) + (name-4 (make-construct 'NameC + :start-revision rev-2 + :instance-of type-1 + :charvalue "name" + :themes nil + :parent top-2))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "variant" + :themes (list scope-1) + :item-identifiers (list ii-3 ii-4) + :parent name-1)) + (variant-2 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "variant" + :themes (list scope-1) + :parent name-4)) + (variant-3 (make-construct 'VariantC + :start-revision rev-2 + :charvalue "variant" + :themes (list scope-1) + :parent name-3))) + (setf *TM-REVISION* rev-3) + (signals not-mergable-error (add-item-identifier variant-2 ii-4)) + (is-false (marked-as-deleted-p top-2)) + (is-false (marked-as-deleted-p top-1)) + (is-false (marked-as-deleted-p name-4)) + (is (eql (add-item-identifier variant-3 ii-4) variant-1)) + (is-true (marked-as-deleted-p top-2)) + (is-false (names top-2)) + (is-false (psis top-2)) + (is-false (set-exclusive-or (list name-1 name-2 name-4) (names top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list variant-1) (variants name-1))) + (is-false (set-exclusive-or (list variant-2) (variants name-4))) + (is (= (length (d::versions top-1)) 2)))))))) + + + +;;TODO: merge associations caused by a merge of their roles @@ -3717,4 +3791,5 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10) ) \ No newline at end of file

1 0

[isidorus-cvs] r290 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 29 Apr '10

29 Apr '10

Author: lgiessmann Date: Thu Apr 29 06:17:20 2010 New Revision: 290 Log: new-datamodel: fixed a problem when topic-merging was caused by reifying the same "ReifiableConstructC"; fixed a bug when two topics are merged and every of these topics reifies a construct that can't be merged with the other one. 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 Thu Apr 29 06:17:20 2010 @@ -3086,6 +3086,15 @@ the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) &key (revision *TM-REVISION*)) + (when (and (reified-construct reifier-topic :revision revision) + (not (equivalent-constructs construct + (reified-construct + reifier-topic :revision revision)))) + (error (make-condition 'not-mergable-error + :message (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable" + reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct) + :construct-1 construct + :construct-2 (reified-construct reifier-topic :revision revision)))) (let ((merged-reifier-topic (if (reifier construct :revision revision) (merge-constructs (reifier construct :revision revision) @@ -3852,7 +3861,9 @@ (let ((source-reified (reified-construct source :revision revision)) (destination-reified (reified-construct destination :revision revision))) - (unless (eql (type-of source-reified) (type-of destination-reified)) + (when (and source-reified destination-reified + (not (eql (type-of source-reified) + (type-of destination-reified)))) (error (make-condition 'not-mergable-error :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" source destination source-reified destination-reified) @@ -3868,10 +3879,10 @@ merged-reified)) (source-reified (delete-reifier source source-reified :revision revision) - (add-reifier destination source-reified :revision revision) + (add-reifier source-reified destination :revision revision) source-reified) (destination-reified - (add-reifier destination destination-reified :revision revision) + (add-reifier destination-reified destination :revision revision) destination-reified))))) 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 29 06:17:20 2010 @@ -88,7 +88,8 @@ :test-merge-constructs-TopicC-5 :test-merge-constructs-TopicC-6 :test-merge-constructs-TopicC-7 - :test-merge-constructs-TopicC-8)) + :test-merge-constructs-TopicC-8 + :test-merge-constructs-TopicC-9)) ;;TODO: test merge-constructs --> associations when merge was caused by @@ -3554,12 +3555,96 @@ (setf *TM-REVISION* rev-3) (signals not-mergable-error (add-reifier occ-3 reifier-1)) (is (eql (add-reifier occ-2 reifier-1) occ-1)) + (is-false (set-exclusive-or (list occ-1 occ-3) (occurrences top-1))) (is-true (marked-as-deleted-p top-2)) - (is-true (marked-as-deleted-p occ-2))))))) + (is-true (marked-as-deleted-p occ-2)) + (is (= (length (d::versions top-1)) 2)) + (is (= (length (d::versions top-2)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (d::versions top-2))) + (is (= (length (slot-value occ-2 'd::parent)) 1)) + (is (= (length (slot-value occ-1 'd::parent)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (first (map 'list #'d::versions + (slot-value occ-2 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent)))))))))) + + +(test test-merge-constructs-TopicC-9 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))) + (let ((top-1 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-2))) + (top-2 (make-construct 'TopicC :start-revision rev-2)) + (top-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (reifier-2 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-1))) + (reifier-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-4 (make-construct 'TopicC :start-revision rev-1)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-1 + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-2 + :charvalue "occ" + :reifier reifier-3 + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-4 + :parent top-3))) + (setf *TM-REVISION* rev-3) + (is (eql (reifier occ-2) reifier-3)) + (signals not-mergable-error (add-reifier occ-1 reifier-3)) + (is (eql occ-1 (add-reifier occ-1 reifier-2))) + (is-true (marked-as-deleted-p reifier-2)) + (is-false (set-exclusive-or (list psi-1) (psis reifier-1))) + (setf *TM-REVISION* rev-4) + (is (eql (add-reifier occ-1 reifier-4) occ-3)) + (is-true (marked-as-deleted-p top-1)) + (is-false (marked-as-deleted-p top-3)) + (is-false (set-exclusive-or (list psi-2) (psis top-3))) + (is-false (marked-as-deleted-p top-2)) + (is-false (set-exclusive-or (list occ-2) (occurrences top-2)))))))) ;;TODO: merge topics caused by variant-item-identifiers -;;TODO: mrege topics caused by reifying the same reified-construct ;;TODO: merge associations caused by a merge of their characteristics @@ -3631,4 +3716,5 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) ) \ No newline at end of file

1 0

[isidorus-cvs] r289 - trunk/src/json
by Lukas Giessmann 28 Apr '10

28 Apr '10

Author: lgiessmann Date: Wed Apr 28 05:35:03 2010 New Revision: 289 Log: json-exporter: fixed a bug in the function "get-all-topics" Modified: trunk/src/json/json_exporter.lisp Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Wed Apr 28 05:35:03 2010 @@ -298,8 +298,10 @@ (remove-if #'null (map 'list #'(lambda(psi-list) (when psi-list (map 'list #'uri psi-list))) - (clean-topics - (elephant:get-instances-by-class 'TopicC)))))) + (map 'list + #'d:psis + (clean-topics + (elephant:get-instances-by-class 'TopicC))))))) (defun to-json-string-summary (topic)

1 0

[isidorus-cvs] r288 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 27 Apr '10

27 Apr '10

Author: lgiessmann Date: Tue Apr 27 15:51:47 2010 New Revision: 288 Log: new-datamodel: fixed bugs in the function: "add-item-identifier", "add-variant" and "make-topic"; added new unit-tests 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 Tue Apr 27 15:51:47 2010 @@ -98,7 +98,7 @@ :charvalue :reified-construct :mark-as-deleted - :mark-as-deleted-p + :marked-as-deleted-p :in-topicmaps :delete-construct :get-revision @@ -152,6 +152,7 @@ :get-all-associations :get-all-tms + ;;globals :*TM-REVISION* :*CURRENT-XTM*)) @@ -159,11 +160,8 @@ (in-package :datamodel) +;;TODO: remove-<xy> --> add to version history??? ;;TODO: adapt changes-lisp -;;TODO: check merge-constructs in add-topic-identifier, -;; add-item-identifier/add-reifier (can merge the parent constructs -;; and the parent's parent construct + the reifier constructs), -;; add-psi, add-locator (--> duplicate-identifier-error) ;;TODO: implement a macro with-merge-constructs, that merges constructs ;; after all operations in the body were called @@ -2483,6 +2481,9 @@ :characteristic variant :parent-construct construct :start-revision revision)) + (when (parent construct :revision revision) + (add-name (parent construct :revision revision) construct + :revision revision)) construct)))) @@ -3046,8 +3047,16 @@ :parent-construct construct :identifier item-identifier :start-revision revision))) - (when (typep construct 'VersionedConstructC) - (add-to-version-history merged-construct :start-revision revision)) + (cond ((typep merged-construct 'VersionedConstructC) + (add-to-version-history merged-construct :start-revision revision)) + ((and (typep merged-construct 'CharacteristicC) + (parent merged-construct :revision revision)) + (add-characteristic (parent merged-construct :revision revision) + merged-construct :revision revision)) + ((and (typep merged-construct 'RoleC) + (parent merged-construct :revision revision)) + (add-role (parent merged-construct :revision revision) + merged-construct :revision revision))) merged-construct)))) @@ -3086,9 +3095,11 @@ (slot-p reifier-topic 'reified-construct)))) (let ((merged-construct construct)) (cond ((reified-construct merged-reifier-topic :revision revision) - (merge-constructs - (reified-construct merged-reifier-topic :revision revision) - construct)) + (let ((merged-reified + (merge-constructs + (reified-construct merged-reifier-topic + :revision revision) construct))) + (setf merged-construct merged-reified))) ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in @@ -3578,7 +3589,8 @@ (item-identifiers (getf args :item-identifiers)) (topic-identifiers (getf args :topic-identifiers)) (names (getf args :names)) - (occurrences (getf args :occurrences))) + (occurrences (getf args :occurrences)) + (reified-construct (getf args :refied-construct))) (when (and (or psis locators item-identifiers topic-identifiers names occurrences) (not start-revision)) @@ -3620,6 +3632,9 @@ :revision start-revision))) (dolist (occ occurrences) (add-occurrence merged-topic occ :revision start-revision)) + (when reified-construct + (add-reified-construct merged-topic reified-construct + :revision start-revision)) merged-topic)))) @@ -3724,26 +3739,6 @@ (add-locator identified-construct identifier :revision start-revision)))) identifier))) - - - - - - - - - - - - - - - - - - - - ;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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 Tue Apr 27 15:51:47 2010 @@ -86,10 +86,13 @@ :test-merge-constructs-TopicC-3 :test-merge-constructs-TopicC-4 :test-merge-constructs-TopicC-5 - :test-merge-constructs-TopicC-6)) + :test-merge-constructs-TopicC-6 + :test-merge-constructs-TopicC-7 + :test-merge-constructs-TopicC-8)) -;;TODO: test merge-constructs +;;TODO: test merge-constructs --> associations when merge was caused by +;; item-identifier of two roles ;;TODO: test mark-as-deleted @@ -3452,13 +3455,113 @@ "ii-1"))))))))) +(test test-merge-constructs-TopicC-7 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (tid-1 (make-construct 'TopicIdentificationC + :uri "tid-1" :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC + :uri "tid-2" :xtm-id "xtm-2")) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-2 (make-construct 'TopicC :start-revision rev-1)) + (top-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list psi-1) + :topic-identifiers (list tid-1))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :locators (list sl-1) + :topic-identifiers (list tid-2)))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1) + :instance-of type-1 + :themes (list scope-1 scope-2) + :charvalue "occ" + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :item-identifiers (list ii-2) + :instance-of type-1 + :themes (list scope-1 scope-2) + :charvalue "occ" + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-3) + :instance-of type-1 + :themes (list scope-1) + :charvalue "occ" + :parent top-1))) + (setf *TM-REVISION* rev-3) + (is (= (length (get-all-topics rev-1)) 4)) + (is (= (length (get-all-topics rev-3)) 5)) + (is (= (length (d::get-db-instances-by-class + 'd::OccurrenceC :revision nil)) 3)) + (signals not-mergable-error (add-item-identifier occ-3 ii-1)) + (is (eql occ-1 (add-item-identifier occ-1 ii-2))) + (is (= (length (get-all-topics rev-3)) 4)) + (is-true (d::marked-as-deleted-p occ-2)) + (is-true (d::marked-as-deleted-p top-2)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers occ-1))) + (is-false (item-identifiers occ-2)) + (is-false (set-exclusive-or (list ii-2) + (item-identifiers occ-2 :revision rev-2))) + (is-false (set-exclusive-or (list psi-1) (psis top-1))) + (is-false (set-exclusive-or (list sl-1) (locators top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (locators top-2))))))) +(test test-merge-constructs-TopicC-8 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((top-1 (make-construct 'TopicC :start-revision rev-1)) + (top-2 (make-construct 'TopicC :start-revision rev-2)) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-1 + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-1 + :charvalue "occ" + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-2 + :charvalue "occ" + :parent top-1))) + (setf *TM-REVISION* rev-3) + (signals not-mergable-error (add-reifier occ-3 reifier-1)) + (is (eql (add-reifier occ-2 reifier-1) occ-1)) + (is-true (marked-as-deleted-p top-2)) + (is-true (marked-as-deleted-p occ-2))))))) + +;;TODO: merge topics caused by variant-item-identifiers +;;TODO: mrege topics caused by reifying the same reified-construct +;;TODO: merge associations caused by a merge of their characteristics -;;TODO: merge topics/associations caused by a merge of their characteristics -;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified -;; by the same reifier @@ -3526,4 +3629,6 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) ) \ No newline at end of file

1 0

[isidorus-cvs] r287 - branches/new-datamodel/src/model
by Lukas Giessmann 23 Apr '10

23 Apr '10

Author: lgiessmann Date: Fri Apr 23 15:51:28 2010 New Revision: 287 Log: new-datamodel: fixed a versioningproblem in "merge-constructs" --> CharacteristicC Modified: branches/new-datamodel/src/model/datamodel.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 Apr 23 15:51:28 2010 @@ -159,9 +159,6 @@ (in-package :datamodel) -;;TODO: replace add-<xy> + add-parent in all merge-constructs where the -;; characteristics are readded to make sure they are added to the current -;; version --> collidates with merge-if-equivalent!!! in merge-constructs ;;TODO: adapt changes-lisp ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs @@ -4067,6 +4064,18 @@ :revision revision) (delete-characteristic parent-2 newer-char :revision revision) + (let ((c-assoc + (find-if + #'(lambda(c-assoc) + (and (eql (characteristic c-assoc) older-char) + (eql (parent-construct c-assoc) parent-1))) + (cond ((typep older-char 'OccurrenceC) + (slot-p parent-1 'occurrences)) + ((typep older-char 'NameC) + (slot-p parent-1 'names)) + ((typep older-char 'VariantC) + (slot-p parent-1 'variants)))))) + (add-to-version-history c-assoc :start-revision revision)) older-char) ((and parent-1 parent-2) (let ((active-parent (merge-constructs parent-1 parent-2 @@ -4185,7 +4194,8 @@ (and (eql (role r-assoc) older-role) (eql (parent-construct r-assoc) parent-1))) (slot-p parent-1 'roles)))) - (add-to-version-history r-assoc :start-revision revision))) + (add-to-version-history r-assoc :start-revision revision) + older-role)) ((and parent-1 parent-2) (let ((active-assoc (merge-constructs parent-1 parent-2 :revision revision)))

1 0

[isidorus-cvs] r286 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 23 Apr '10

23 Apr '10

Author: lgiessmann Date: Fri Apr 23 14:47:37 2010 New Revision: 286 Log: new-datamodel: fixed an elephant bug that appears in the current version --> "get-instances-by-class" is embraced within a function that filters all instances by typep and optional a given revision; fixed a potential versioning bug in "merge-all-constructs"; fixed a bug in "equivalent-construct" --> AssociationC; fixed a bug in "merge-changed-constructs"; fixed a bug in "merge-constructs" --> the returned association object is added to the union of all tms the given associations were present in; added some unit-tests 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 Apr 23 14:47:37 2010 @@ -148,6 +148,9 @@ :check-for-duplicate-identifiers :find-item-by-content :rec-remf + :get-all-topics + :get-all-associations + :get-all-tms ;;globals :*TM-REVISION* @@ -156,10 +159,10 @@ (in-package :datamodel) - -;;TODO: mark-as-deleted should call mark-as-deleted for every owned ??? -;; versioned-construct of the called construct, same for add-xy ??? -;; and associations of player +;;TODO: replace add-<xy> + add-parent in all merge-constructs where the +;; characteristics are readded to make sure they are added to the current +;; version --> collidates with merge-if-equivalent!!! in merge-constructs +;;TODO: adapt changes-lisp ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -701,6 +704,34 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) + "Returns all instances of the given type and the given revision that are + stored in the db." + (declare (symbol class-symbol) (type (or null integer) revision)) + (let ((db-instances (elephant:get-instances-by-class class-symbol))) + (let ((filtered-instances (remove-if-not #'(lambda(inst) + (typep inst class-symbol)) + db-instances))) + (if revision + (remove-if #'null + (map 'list #'(lambda(inst) + (find-item-by-revision inst revision)) + filtered-instances)) + filtered-instances)))) + + +(defun get-all-topics (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicC :revision revision)) + + +(defun get-all-associations (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'AssociationC :revision revision)) + + +(defun get-all-tms (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicMapC :revision revision)) + + (defun find-version-info (versioned-constructs &key (sort-function #'<) (sort-key 'start-revision)) "Returns all version-infos sorted by the function sort-function which is @@ -811,14 +842,15 @@ (condition () nil))) -(defun merge-all-constructs(constructs-to-be-merged) +(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*)) "Merges all constructs contained in the given list." (declare (list constructs-to-be-merged)) (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1)) (merged-construct (elt constructs-to-be-merged 0))) (loop for construct-to-be-merged in constructs-to-be-merged do (setf merged-construct - (merge-constructs merged-construct construct-to-be-merged))))) + (merge-constructs merged-construct construct-to-be-merged + :revision revision))))) (defgeneric internal-id (construct) @@ -980,7 +1012,7 @@ ;;; VersionedConstructC -(defgeneric exist-in-revision-history-? (versioned-construct) +(defgeneric exist-in-version-history-p (versioned-construct) (:documentation "Returns t if the passed construct does not exist in any revision, i.e. the construct has no version-infos or exactly one whose start-revision is equal to its end-revision.") @@ -1106,8 +1138,16 @@ (let ((last-version ;the last active version (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision)))) + (if (and last-version + (= (start-revision last-version) revision)) + (progn + (delete-construct last-version) + (let ((sorted-versions + (sort (versions construct) #'> :key #'end-revision))) + (when sorted-versions + (setf (end-revision (first sorted-versions)) revision)))) + (when last-version + (setf (end-revision last-version) revision))))) ;;; TopicMapconstructC @@ -2494,9 +2534,14 @@ (and (eql (instance-of construct-1 :revision revision) (instance-of construct-2 :revision revision)) (not (set-exclusive-or (themes construct-1 :revision revision) - (themes construct-1 :revision revision))) - (not (set-exclusive-or (roles construct-1 :revision revision) - (roles construct-2 :revision revision))))) + (themes construct-2 :revision revision))) + + (not (set-exclusive-or + (roles construct-1 :revision revision) + (roles construct-2 :revision revision) + :test #'(lambda(role-1 role-2) + (strictly-equivalent-constructs role-1 role-2 + :revision revision)))))) (defgeneric AssociationC-p (class-symbol) @@ -2517,21 +2562,22 @@ (type (or null TopicC) instance-of)) ;; item-identifiers and reifers are not checked because the equality have to ;; be variafied without them - (let ((checked-roles - (loop for assoc-role in (roles construct :revision start-revision) - when (loop for plist in roles - when (equivalent-construct - assoc-role :player (getf plist :player) - :start-revision (or (getf plist :start-revision) - start-revision) - :instance-of (getf plist :instance-of)) - return t) - collect assoc-role))) + (let ((checked-roles nil)) + (loop for plist in roles + do (let ((found-role + (find-if #'(lambda(assoc-role) + (equivalent-construct + assoc-role :player (getf plist :player) + :start-revision (or (getf plist :start-revision) + start-revision) + :instance-of (getf plist :instance-of))) + (roles construct :revision start-revision)))) + (when found-role + (push found-role checked-roles)))) (and (not (set-exclusive-or (roles construct :revision start-revision) checked-roles)) - (= (length (roles construct :revision start-revision)) - (length roles)) + (= (length checked-roles) (length roles)) (equivalent-typable-construct construct instance-of :start-revision start-revision) (equivalent-scopable-construct construct themes @@ -3428,9 +3474,10 @@ :roles roles :themes themes :instance-of instance-of) existing-association)) - (elephant:get-instances-by-class 'AssociationC))))) + (get-all-associations nil))))) (cond ((> (length existing-associations) 1) - (merge-all-constructs existing-associations)) + (merge-all-constructs existing-associations + :revision start-revision)) (existing-associations (first existing-associations)) (t @@ -3512,9 +3559,9 @@ :item-identifiers item-identifiers :reifier reifier) existing-tm)) - (elephant:get-instances-by-class 'TopicMapC))))) + (get-all-tms start-revision))))) (cond ((> (length existing-tms) 1) - (merge-all-constructs existing-tms)) + (merge-all-constructs existing-tms :revision start-revision)) (existing-tms (first existing-tms)) (t @@ -3554,9 +3601,9 @@ :item-identifiers item-identifiers :topic-identifiers topic-identifiers) existing-topic)) - (elephant:get-instances-by-class 'TopicC))))) + (get-all-topics start-revision))))) (cond ((> (length existing-topics) 1) - (merge-all-constructs existing-topics)) + (merge-all-constructs existing-topics :revision start-revision)) (existing-topics (first existing-topics)) (t @@ -3919,23 +3966,61 @@ (let ((parent (when (or (typep construct 'RoleC) (typep construct 'CharacteristicC)) (parent construct :revision revision)))) - (let ((found-equivalent - (find-if #'(lambda(other-construct) - (strictly-equivalent-constructs - other-construct construct :revision revision)) - (cond ((typep construct 'OccurrenceC) - (occurrences parent :revision revision)) - ((typep construct 'NameC) - (names parent :revision revision)) - ((typep construct 'VariantC) - (variants parent :revision revision)) - ((typep construct 'RoleC) - (roles parent :revision revision)) - ((typep construct 'AssociationC) - (elephant:get-instances-by-class 'AssociationC)))))) - (when found-equivalent - (merge-all-constructs (append found-equivalent (list construct)))))))) - + (let ((all-other (cond ((typep construct 'OccurrenceC) + (occurrences parent :revision revision)) + ((typep construct 'NameC) + (names parent :revision revision)) + ((typep construct 'VariantC) + (variants parent :revision revision)) + ((typep construct 'RoleC) + (roles parent :revision revision))))) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(other) + (when (strictly-equivalent-constructs + construct other :revision revision) + other)) + all-other)))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list construct)) + :revision revision)))))) + (merge-changed-associations older-topic :revision revision)) + + +(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) + "Merges all associations that became TMDM-equal since two referenced topics + were merged, e.g. the association types." + (declare (TopicC older-topic)) + (let ((all-assocs + (remove-duplicates + (append + (remove-if + #'null + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles older-topic :revision revision))) + (remove-if + #'null + (map + 'list #'(lambda(constr) + (when (typep constr 'AssociationC) + constr)) + (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision)))))))) + (dolist (assoc all-assocs) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(db-assoc) + (when (strictly-equivalent-constructs + assoc db-assoc :revision revision) + db-assoc)) + (get-all-associations nil))))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list assoc)) + :revision revision)))))) + (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) @@ -3953,7 +4038,7 @@ (move-reified-construct newer-topic older-topic :revision revision) (merge-changed-constructs older-topic :revision revision) (mark-as-deleted newer-topic :revision revision :source-locator nil) - (when (exist-in-revision-history-? newer-topic) + (when (exist-in-version-history-p newer-topic) (delete-construct newer-topic)) older-topic)))) @@ -3980,7 +4065,7 @@ (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-char older-char :revision revision) - (delete-characteristic newer-char parent-2 + (delete-characteristic parent-2 newer-char :revision revision) older-char) ((and parent-1 parent-2) @@ -4032,7 +4117,7 @@ (add-to-tm top-or-assoc top-or-assoc)) (add-to-version-history older-tm :start-revision revision) (mark-as-deleted newer-tm :revision revision) - (when (exist-in-revision-history-? newer-tm) + (when (exist-in-version-history-p newer-tm) (delete-construct newer-tm)) older-tm)))) @@ -4053,6 +4138,8 @@ construct-1 construct-2) :construct-1 construct-1 :construct-2 construct-2))) + (dolist (tm (in-topicmaps newer-assoc :revision revision)) + (add-to-tm tm older-assoc)) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4065,7 +4152,7 @@ (delete-role newer-assoc newer-role :revision revision) (add-role older-assoc equivalent-role :revision revision))) (mark-as-deleted newer-assoc :revision revision) - (when (exist-in-revision-history-? newer-assoc) + (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) older-assoc)))) @@ -4091,8 +4178,14 @@ (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-role older-role :revision revision) - (delete-role newer-role parent-2 :revision revision) - (add-role older-role parent-1 :revision revision)) + (delete-role parent-2 newer-role :revision revision) + (let ((r-assoc + (find-if + #'(lambda(r-assoc) + (and (eql (role r-assoc) older-role) + (eql (parent-construct r-assoc) parent-1))) + (slot-p parent-1 'roles)))) + (add-to-version-history r-assoc :start-revision revision))) ((and parent-1 parent-2) (let ((active-assoc (merge-constructs parent-1 parent-2 :revision 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 Apr 23 14:47:37 2010 @@ -81,7 +81,12 @@ :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC :test-move-referenced-constructs-NameC - :test-merge-constructs-TopicC-1)) + :test-merge-constructs-TopicC-1 + :test-merge-constructs-TopicC-2 + :test-merge-constructs-TopicC-3 + :test-merge-constructs-TopicC-4 + :test-merge-constructs-TopicC-5 + :test-merge-constructs-TopicC-6)) ;;TODO: test merge-constructs @@ -1815,7 +1820,7 @@ :start-revision rev-1)) (role-2 (list :player player-2 :instance-of r-type-2 :start-revision rev-1)) - (role-3 (list :instance-of r-type-3 :player player-3 + (role-3 (list :player player-3 :instance-of r-type-3 :start-revision rev-1)) (type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) @@ -1877,7 +1882,7 @@ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-3)) (is-false (d::strictly-equivalent-constructs assoc-1 assoc-4)) (is-false (d::strictly-equivalent-constructs assoc-1 assoc-5)) - (is-false (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) + (is-true (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) (test test-equivalent-TopicC () @@ -3046,6 +3051,414 @@ (is-true (d::marked-as-deleted-p occ-3)))))))))) +(test test-merge-constructs-TopicC-2 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (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")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-2")) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (variant-2 (make-construct 'VariantC + :start-revision rev-2 + :charvalue "var-2" + :themes (list theme-2))) + (variant-3 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1))) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-2" + :instance-of type-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-2 + :item-identifiers (list ii-3) + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1)))) + (let ((name-1 (make-construct 'NameC + :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-3 + :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) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 6)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 3)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (let ((top (d::merge-constructs top-1 top-2 :revision rev-3))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (is (eql top top-1)) + (is-false (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + (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)))))))))) + + +(test test-merge-constructs-TopicC-3 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (n-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")) + (ii-5 (make-construct 'ItemIdentifierC :uri "ii-5")) + (ii-6 (make-construct 'ItemIdentifierC :uri "ii-6")) + (var-0-1 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1")) + (var-0-2 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1"))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1) + :charvalue "occ" + :instance-of type-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-2) + :charvalue "occ" + :instance-of type-2)) + (name-1 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-3) + :variants (list var-0-1) + :charvalue "name" + :instance-of type-1)) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-4) + :variants (list var-0-2) + :charvalue "name" + :instance-of type-2)) + (var-1 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-5) + :charvalue "var" + :themes (list type-1))) + (var-2 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-6) + :charvalue "var" + :themes (list type-2)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :occurrences (list occ-1 occ-2) + :names (list name-1 name-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3" + :instance-of n-type + :variants (list var-1 var-2)))) + (let ((top-2 (make-construct 'TopicC + :start-revision rev-1 + :names (list name-3)))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (occurrences top-1)) 1)) + (is-false (set-exclusive-or + (list ii-1 ii-2) + (item-identifiers (first (occurrences top-1))))) + (is (= (length (slot-value top-1 'd::occurrences)) 2)) + (is (= (length (names top-1)) 1)) + (is-false (set-exclusive-or + (list ii-3 ii-4) + (item-identifiers (first (names top-1))))) + (is (= (length (slot-value top-1 'd::names)) 2)) + (is-false (set-exclusive-or (list var-0-1 var-0-2) + (variants (first (names top-1))))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(occ) + (eql occ (first (occurrences top-1)))) + (slot-value top-1 'd::occurrences)))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(name) + (eql name (first (names top-1)))) + (slot-value top-1 'd::names)))) + (is (= (length (variants (first (names top-2)))) 1)) + (is (= (length (slot-value (first (names top-2)) 'd::variants)) 2)) + (is (eql (first (themes (first (variants (first (names top-2)))))) + type-1))))))))) + + +(test test-merge-constructs-TopicC-4 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (r-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player type-1 + :instance-of r-type + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player type-2 + :item-identifiers (list ii-2) + :instance-of r-type + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-1)) 1)) + (is (= (length (slot-value assoc-1 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-1))) r-type)) + (is (eql (player (first (roles assoc-1))) type-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-1))))) + (let ((active-role (first (roles assoc-1))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-1)))) + (slot-value assoc-1 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-5 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player player-1 + :instance-of type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-1 + :item-identifiers (list ii-2) + :instance-of type-2 + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-2)) 1)) + (is (= (length (slot-value assoc-2 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-2))) type-1)) + (is (eql (player (first (roles assoc-2))) player-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-2))))) + (let ((active-role (first (roles assoc-2))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-2)))) + (slot-value assoc-2 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-6 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (r-type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-2 (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (player-2 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) + (let ((assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :item-identifiers (list ii-3) + :roles (list (list :player player-1 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-2 + :instance-of r-type-2 + :start-revision rev-1)))) + (assoc-4 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-2 + :item-identifiers (list ii-4) + :roles (list (list :player player-1 + :instance-of r-type-1 + :start-revision rev-2) + (list :player player-2 + :item-identifiers (list ii-2) + :instance-of r-type-2 + :start-revision rev-2))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (d::versions assoc-3)) 2)) + (is (= (length (d::versions assoc-4)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-1) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-3) + (= (d::end-revision vi) 0))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-2) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-4))) + (is (= (length (roles assoc-3)) 2)) + (is (= (length (item-identifiers (first (roles assoc-3)))) 1)) + (is (= (length (item-identifiers (second (roles assoc-3)))) 1)) + (is (or (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-1") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-2")) + (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-2") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-1"))))))))) + + + + + + +;;TODO: merge topics/associations caused by a merge of their characteristics +;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified +;; by the same reifier @@ -3108,4 +3521,9 @@ (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-2) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-3) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) ) \ No newline at end of file

1 0

[isidorus-cvs] r285 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Apr '10

22 Apr '10

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

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs