[isidorus-cvs] r293 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Sun May 2 12:00:43 UTC 2010
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)
More information about the Isidorus-cvs
mailing list