May 2010 - isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

[isidorus-cvs] r295 - branches/new-datamodel/src branches/new-datamodel/src/json branches/new-datamodel/src/model trunk/src
by Lukas Giessmann 25 May '10

25 May '10

Author: lgiessmann Date: Tue May 25 14:10:18 2010 New Revision: 295 Log: fixed a problem with sbcl/asdf and the sb-impl::*default-external-format* --> now it is set to :utf-8 during the loading process and then set to its old value Modified: branches/new-datamodel/src/isidorus.asd branches/new-datamodel/src/json/json_importer.lisp branches/new-datamodel/src/model/changes.lisp trunk/src/isidorus.asd Modified: branches/new-datamodel/src/isidorus.asd ============================================================================== --- branches/new-datamodel/src/isidorus.asd (original) +++ branches/new-datamodel/src/isidorus.asd Tue May 25 14:10:18 2010 @@ -12,6 +12,9 @@ (:use :asdf :cl)) (in-package :isidorus-system) +(defvar *old-external-format* sb-impl::*default-external-format*) +(setf sb-impl::*default-external-format* :UTF-8) + (asdf:defsystem "isidorus" :description "The future ingenious, self-evaluating Lisp TM engine" :version "0.1" @@ -202,6 +205,9 @@ :uuid :cl-json)) +(setf sb-impl::*default-external-format* *old-external-format*) + + ;; ;; For the package pathnames, create a link from ~/.sbcl/systems ;; to the file pathnames.asd in Seibel's pathname-library. Modified: branches/new-datamodel/src/json/json_importer.lisp ============================================================================== --- branches/new-datamodel/src/json/json_importer.lisp (original) +++ branches/new-datamodel/src/json/json_importer.lisp Tue May 25 14:10:18 2010 @@ -244,12 +244,10 @@ (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 :start-revision start-revision :topic top Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Tue May 25 14:10:18 2010 @@ -140,7 +140,7 @@ * (for topics) modified through the addition or removal of an association in which it is first player")) (defmethod changed-p ((construct TopicMapConstructC) (revision integer)) - "The 'normal' case: changes only when new identifiers are added" + "The 'normal' case: changes only when new identifiers are added" (find revision (versions construct) :test #'= :key #'start-revision)) ;There is quite deliberately no method specialized on AssociationC as Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue May 25 14:10:18 2010 @@ -12,6 +12,9 @@ (:use :asdf :cl)) (in-package :isidorus-system) +(defvar *old-external-format* sb-impl::*default-external-format*) +(setf sb-impl::*default-external-format* :UTF-8) + (asdf:defsystem "isidorus" :description "The future ingenious, self-evaluating Lisp TM engine" :version "0.1" @@ -201,6 +204,9 @@ :uuid :cl-json)) + +(setf sb-impl::*default-external-format* *old-external-format*) + ;; ;; For the package pathnames, create a link from ~/.sbcl/systems ;; to the file pathnames.asd in Seibel's pathname-library.

1 0

[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