[isidorus-cvs] r268 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Apr 8 09:55:12 UTC 2010
Author: lgiessmann
Date: Thu Apr 8 05:55:12 2010
New Revision: 268
Log:
new-datamodel: fixed a versioning-problem in all "delete-<xy>\ generics; added the exceptions "tm-reference-error", "missing-argument-error" and "not-mergable-error"; adapt the data-model'S unit-tests to the last modifications
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/model/exceptions.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Thu Apr 8 05:55:12 2010
@@ -11,12 +11,13 @@
(:use :cl :elephant :constants)
(:nicknames :d)
(:import-from :exceptions
- duplicate-identifier-error)
- (:import-from :exceptions
- object-not-found-error)
- (:import-from :constants
- *xml-string*)
+ duplicate-identifier-error
+ object-not-found-error
+ missing-argument-error
+ not-mergable-error
+ tm-reference-error)
(:import-from :constants
+ *xml-string*
*instance-psi*)
(:export ;;classes
:TopicMapConstructC
@@ -155,15 +156,9 @@
(in-package :datamodel)
-;;TODO: call delete-construct for all child-constructs that are:
-;; *exist-in-revision-history => nil
-;; *are not referenced by other constructs
-;; --> iis, psis, sls, tids, names, occs, variants, roles
-;;TODO: mark-as-deleted should call mark-as-deleted for every owned
-;; versioned-construct of the called construct
-;;TODO: add: add-to-version-history (parent) to all
-;; "add-<construct>"/"delete-<construct>" generics
-;; ===>> adapt exist-in-revision-history
+
+;;TODO: mark-as-deleted should call mark-as-deleted for every owned ???
+;; versioned-construct of the called construct, same for add-xy ???
;;TODO: check for duplicate identifiers after topic-creation/merge
;;TODO: check merge-constructs in add-topic-identifier,
;; add-item-identifier/add-reifier (can merge the parent constructs
@@ -172,8 +167,6 @@
;;TODO: implement a macro "with-merge-construct" that merges constructs
;; after some data-operations are completed (should be passed as body)
;; and a merge should be done
-;;TODO: use some exceptions --> more than one type,
-;; identifier, not-mergable merges, missing-init-args...
@@ -261,7 +254,11 @@
:accessor uri
:inherit t
:type string
- :initform (error "From PointerC(): uri must be set for a pointer")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PointerC(): uri must be set for a pointer"
+ :argument-symbol 'uri
+ :function-symbol ':uri))
:index t
:documentation "The actual value of a pointer, i.e. uri or ID.")
(identified-construct :associate (PointerAssociationC identifier)
@@ -281,7 +278,11 @@
((xtm-id :initarg :xtm-id
:accessor xtm-id
:type string
- :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+ :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))
:index t
:documentation "ID of the TM this identification came from."))
(:index t)
@@ -439,13 +440,21 @@
(defpclass TypeAssociationC(VersionedAssociationC)
((type-topic :initarg :type-topic
:accessor type-topic
- :initform (error "From TypeAssociationC(): type-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From TypeAssociationC(): type-topic must be set"
+ :argument-symbol 'type-topic
+ :function-symbol ':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 "From TypeAssociationC(): typable-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From TypeAssociationC(): typable-construct must be set"
+ :argument-symbol 'typable-construct
+ :function-symbol ':typable-construct))
:associate TypableC
:documentation "Associates this object with the typable
construct that is typed by the
@@ -458,13 +467,21 @@
(defpclass ScopeAssociationC(VersionedAssociationC)
((theme-topic :initarg :theme-topic
:accessor theme-topic
- :initform (error "From ScopeAssociationC(): theme-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ScopeAssociationC(): theme-topic must be set"
+ :argument-symbol 'theme-topic
+ :function-symbol ':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 "From ScopeAssociationC(): scopable-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ScopeAssociationC(): scopable-construct must be set"
+ :argument-symbol 'scopable-construct
+ :function-symbol ':scopable-construct))
:associate ScopableC
:documentation "Associates this object with the socpable
construct that is scoped by the
@@ -477,13 +494,21 @@
(defpclass ReifierAssociationC(VersionedAssociationC)
((reifiable-construct :initarg :reifiable-construct
:accessor reifiable-construct
- :initform (error "From ReifierAssociation(): reifiable-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ReifierAssociation(): reifiable-construct must be set"
+ :argument-symbol 'reifiable-construct
+ :function-symbol ':reifiable-construct))
:associate ReifiableConstructC
:documentation "The actual construct which is reified
by a topic.")
(reifier-topic :initarg :reifier-topic
:accessor reifier-topic
- :initform (error "From ReifierAssociationC(): reifier-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ReifierAssociationC(): reifier-topic must be set"
+ :argument-symbol 'reifier-topic
+ :function-symbol ':reifier-topic))
:associate TopicC
:documentation "The reifier-topic that reifies the
reifiable-construct."))
@@ -496,7 +521,11 @@
((identifier :initarg :identifier
:accessor identifier
:inherit t
- :initform (error "From PointerAssociationC(): identifier must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PointerAssociationC(): identifier must be set"
+ :argument-symbol 'identifier
+ :function-symbol ':identifier))
:associate PointerC
:documentation "The actual data that is associated with
the pointer-association's parent."))
@@ -507,7 +536,11 @@
(defpclass SubjectLocatorAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From SubjectLocatorAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-symbol))
:associate TopicC
:documentation "The actual topic which is associated
with the subject-locator."))
@@ -518,7 +551,11 @@
(defpclass PersistentIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PersistentIdAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "The actual topic which is associated
with the subject-identifier/psi."))
@@ -529,7 +566,11 @@
(defpclass TopicIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From TopicIdAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-arguement-error
+ :message "From TopicIdAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "The actual topic which is associated
with the topic-identifier."))
@@ -540,7 +581,11 @@
(defpclass ItemIdAssociationC(PointerAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From ItemIdAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From ItemIdAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate ReifiableConstructC
:documentation "The actual parent which is associated
with the item-identifier."))
@@ -553,7 +598,11 @@
((characteristic :initarg :characteristic
:accessor characteristic
:inherit t
- :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From CharacteristicCAssociation(): characteristic must be set"
+ :argument-symbol 'characteristic
+ :function-symbol ':characteristic))
:associate CharacteristicC
:documentation "Associates this object with the actual
characteristic object."))
@@ -564,7 +613,11 @@
(defpclass VariantAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From VariantAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From VariantAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate NameC
:documentation "Associates this object with a name."))
(:documentation "Associates variant objects with name obejcts.
@@ -574,7 +627,11 @@
(defpclass NameAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From NameAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From NameAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "Associates this object with a topic."))
(:documentation "Associates name objects with their parent topics.
@@ -584,7 +641,11 @@
(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
((parent-construct :initarg :parent-construct
:accessor parent-construct
- :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From OccurrenceAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:associate TopicC
:documentation "Associates this object with a topic."))
(:documentation "Associates occurrence objects with their parent topics.
@@ -596,13 +657,21 @@
((player-topic :initarg :player-topic
:accessor player-topic
:associate TopicC
- :initform (error "From PlayerAssociationC(): player-topic must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PlayerAssociationC(): player-topic must be set"
+ :argument-symbol 'player-topic
+ :function-symbol ':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 "From PlayerAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From PlayerAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:documentation "Associates this object with the parent-association."))
(:documentation "This class associates roles and their player in given
revisions."))
@@ -612,12 +681,20 @@
((role :initarg :role
:accessor role
:associate RoleC
- :initform (error "From RoleAssociationC(): role must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From RoleAssociationC(): role must be set"
+ :argument-symbol 'role
+ :function-symbol ':role))
:documentation "Associates this objetc with a role-object.")
(parent-construct :initarg :parent-construct
:accessor parent-construct
:associate AssociationC
- :initform (error "From RoleAssociationC(): parent-construct must be set")
+ :initform (error
+ (make-condition 'missing-argument-error
+ :message "From RoleAssociationC(): parent-construct must be set"
+ :argument-symbol 'parent-construct
+ :function-symbol ':parent-construct))
:documentation "Assocates thius object with an
association-object."))
(:documentation "Associates roles with assoications and adds some
@@ -763,6 +840,11 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric delete-if-not-referenced (construct)
+ (:documentation "Calls delete-construct for the given object if it is
+ not referenced by any other construct."))
+
+
(defgeneric add-characteristic (construct characteristic &key revision)
(:documentation "Adds the passed characterisitc to the given topic by calling
add-name or add-occurrences.
@@ -955,7 +1037,11 @@
(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 "From add-to-version-history(): start revision must be present"))
+ &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)))
(end-revision 0))
(let ((eql-version-info
(find-if #'(lambda(vi)
@@ -1370,7 +1456,6 @@
construct xtm-id))))
(uri (first possible-identifiers)))
(concatenate 'string "t" (write-to-string (internal-id construct))))))
-
(defgeneric topic-identifiers (construct &key revision)
@@ -1422,13 +1507,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
- &key (revision (error "From delete-topic-identifier(): revision must be set")))
+ &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))))
(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)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1478,13 +1566,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (psi PersistentIdC)
- &key (revision (error "From delete-psi(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-psi(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol '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)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1535,13 +1626,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (locator SubjectLocatorC)
- &key (revision (error "From delete-locator(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-locator(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol '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)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1572,8 +1666,12 @@
&key (revision *TM-REVISION*))
(when (and (parent name :revision revision)
(not (eql (parent name :revision revision) construct)))
- (error "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)))
+ (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)))
(let ((all-names
(map 'list #'characteristic (slot-p construct 'names))))
(if (find name all-names)
@@ -1594,13 +1692,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (name NameC)
- &key (revision (error "From delete-name(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-name(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol '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)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1623,8 +1724,12 @@
&key (revision *TM-REVISION*))
(when (and (parent occurrence :revision revision)
(not (eql (parent occurrence :revision revision) construct)))
- (error "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)))
+ (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))
(let ((all-occurrences
(map 'list #'characteristic (slot-p construct 'occurrences))))
(if (find occurrence all-occurrences)
@@ -1644,13 +1749,16 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct TopicC) (occurrence OccurrenceC)
- &key (revision (error "From delete-occurrence(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-occurrence(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-construct))))
(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)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -1777,7 +1885,9 @@
(when (find-item-by-revision top-from-oid revision)
top-from-oid))))))
(if (and error-if-nil (not result))
- (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)
+ (error (make-condition 'object-not-found-error
+ :message (format nil "No such item (id: ~a, tm: ~a, rev: ~a)"
+ topic-id xtm-id revision)))
result)))
@@ -1802,12 +1912,13 @@
:uri uri)))
(identified-construct (first possible-ids)
:revision revision)))))
- ;no revision need not to be checked, since the revision
+ ;no revision need to be checked, since the revision
;is implicitely checked by the function identified-construct
(if result
result
(when error-if-nil
- (error "No such item is bound to the given identifier uri.")))))
+ (error (make-condition 'object-not-found-error
+ :message "No such item is bound to the given identifier uri."))))))
(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*)
@@ -1887,6 +1998,13 @@
;;; CharacteristicC
+(defmethod delete-if-not-referenced ((construct CharacteristicC))
+ (let ((references (slot-p construct 'parent)))
+ (when (and (<= (length references) 1)
+ (marked-as-deleted-p (first references)))
+ (delete-construct construct))))
+
+
(defmethod find-oldest-construct ((construct-1 CharacteristicC)
(construct-2 CharacteristicC))
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
@@ -2003,8 +2121,12 @@
return parent-assoc)))
(when (and already-set-parent
(not (eql already-set-parent parent-construct)))
- (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
- construct parent-construct already-set-parent))
+ (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)))
(cond (already-set-parent
(let ((parent-assoc
(loop for parent-assoc in (slot-p construct 'parent)
@@ -2032,15 +2154,18 @@
(defmethod delete-parent ((construct CharacteristicC)
(parent-construct ReifiableConstructC)
- &key (revision (error "From delete-parent(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-parent(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol '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))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (when (typep parent-construct 'VersionedConstructC)
+ (add-to-version-history parent-construct :start-revision revision)))
construct))
@@ -2159,8 +2284,12 @@
&key (revision *TM-REVISION*))
(when (and (parent variant :revision revision)
(not (eql (parent variant :revision revision) construct)))
- (error "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)))
+ (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)))
(let ((all-variants
(map 'list #'characteristic (slot-p construct 'variants))))
(if (find variant all-variants)
@@ -2180,7 +2309,10 @@
(:documentation "Deletes the passed variant by marking it's association as
deleted in the passed revision.")
(:method ((construct NameC) (variant VariantC)
- &key (revision (error "From delete-variant(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-variant(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-variant))))
(let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
'variants)
when (eql (characteristic variant-assoc) variant)
@@ -2305,13 +2437,16 @@
(:documentation "Deletes the passed role by marking it's association as
deleted in the passed revision.")
(:method ((construct AssociationC) (role RoleC)
- &key (revision (error "From delete-role(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-role(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol '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)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history construct :start-revision revision))
construct)))
@@ -2320,6 +2455,13 @@
;;; RoleC
+(defmethod delete-if-not-referenced ((construct RoleC))
+ (let ((references (slot-p construct 'parent)))
+ (when (and (<= (length references) 1)
+ (marked-as-deleted-p (first references)))
+ (delete-construct construct))))
+
+
(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC))
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
(vi-2 (find-version-info (slot-p construct-2 'parent))))
@@ -2429,8 +2571,12 @@
return parent-assoc)))
(when (and already-set-parent
(not (eql already-set-parent parent-construct)))
- (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
- construct parent-construct already-set-parent))
+ (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)))
(cond (already-set-parent
(let ((parent-assoc
(loop for parent-assoc in (slot-p construct 'parent)
@@ -2450,14 +2596,17 @@
(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
- &key (revision (error "From delete-parent(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-parent(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol '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)
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (add-to-version-history parent-construct :start-revision revision))
construct))
@@ -2483,8 +2632,12 @@
return player-assoc)))
(when (and already-set-player
(not (eql already-set-player player-topic)))
- (error "From add-player(): ~a can't be played by ~a since it is played by ~a"
- construct player-topic already-set-player))
+ (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)))
(cond (already-set-player
(let ((player-assoc
(loop for player-assoc in (slot-p construct 'player)
@@ -2505,7 +2658,10 @@
(: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 "From delete-parent(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-parent(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-player))))
(let ((assoc-to-delete
(loop for player-assoc in (slot-p construct 'player)
when (eql (parent-construct player-assoc) construct)
@@ -2652,14 +2808,17 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
- &key (revision (error "From delete-item-identifier(): revision must be set")))
+ &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))))
(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))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (when (typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision revision)))
construct)))
@@ -2706,14 +2865,17 @@
(:documentation "Sets the association object between the passed constructs
as mark-as-deleted.")
(:method ((construct ReifiableConstructC) (reifier TopicC)
- &key (revision (error "From delete-reifier(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-reifier(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol '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))
+ (mark-as-deleted assoc-to-delete :revision revision)
+ (when (typep construct 'VersionedConstructC)
+ (add-to-version-history construct :start-revision revision)))
construct)))
@@ -2824,7 +2986,10 @@
(: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 "From delete-theme(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-theme(): revision must be set"
+ :argument-symbol 'revsion
+ :function-symbol '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)))
@@ -2873,8 +3038,12 @@
return type-assoc)))
(when (and already-set-type
(not (eql type-topic already-set-type)))
- (error "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
- construct 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)))
(cond (already-set-type
(let ((type-assoc
(loop for type-assoc in (slot-p construct 'instance-of)
@@ -2897,7 +3066,10 @@
(: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 "From delete-type(): revision must be set")))
+ &key (revision (error (make-condition 'missing-argument-error
+ :message "From delete-type(): revision must be set"
+ :argument-symbol 'revision
+ :function-symbol 'delete-type))))
(let ((assoc-to-delete
(loop for type-assoc in (slot-p construct 'instance-of)
when (eql (type-topic type-assoc) type-topic)
@@ -2986,7 +3158,10 @@
(and (ReifiableConstructC-p class-symbol)
(or (getf args :item-identifiers) (getf args :reifier))))
(not (getf args :start-revision)))
- (error "From make-construct(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-construct(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-construct)))
(let ((construct
(cond
((PointerC-p class-symbol)
@@ -3034,7 +3209,10 @@
(roles (getf args :roles)))
(when (and (or roles instance-of themes)
(not start-revision))
- (error "From make-association(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-association(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-association)))
(let ((association
(let ((existing-associations
(remove-if
@@ -3071,7 +3249,10 @@
(start-revision (getf args :start-revision)))
(when (and (or instance-of player parent)
(not start-revision))
- (error "From make-role(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-role(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-role)))
(let ((role
(let ((existing-roles
(when parent
@@ -3109,7 +3290,10 @@
(start-revision (getf args :start-revision)))
(when (and (or item-identifiers reifier)
(not start-revision))
- (error "From make-tm(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-tm(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-tm)))
(let ((tm
(let ((existing-tms
(remove-if
@@ -3146,7 +3330,10 @@
(when (and (or psis locators item-identifiers topic-identifiers
names occurrences)
(not start-revision))
- (error "From make-topic(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-topic(): start-revision must be set"
+ :argument-symbol 'start-revision
+ :function-symbol 'make-topic)))
(let ((topic
(let ((existing-topics
(remove-if
@@ -3199,7 +3386,10 @@
(parent (getf args :parent)))
(when (and (or instance-of themes variants parent)
(not start-revision))
- (error "From make-characteristic(): start-revision must be set"))
+ (error (make-condition 'missing-argument-error
+ :message "From make-characteristic(): start-revision must be set"
+ :argument-symbol 'start-revsion
+ :function-symbol 'make-characgteristic)))
(let ((characteristic
(let ((existing-characteristic
(when parent
@@ -3235,12 +3425,21 @@
(identified-construct (getf args :identified-construct))
(err "From make-pointer(): "))
(when (and identified-construct (not start-revision))
- (error "~astart-revision must be set" err))
+ (error (make-condition 'missing-argument-error
+ :message (format nil "~astart-revision must be set" err)
+ :argument-symbol 'start-revision
+ :function-symbol 'make-pointer)))
(unless uri
- (error "~auri must be set" err))
+ (error (make-condition 'missing-argument-error
+ :message (format nil "~auri must be set" err)
+ :argument-symbol 'uri
+ :function-symbol 'make-pointer)))
(when (and (TopicIdentificationC-p class-symbol)
(not xtm-id))
- (error "~axtm-id must be set" err))
+ (error (make-condition 'missing-argument-error
+ :message (format nil "~axtm-id must be set" err)
+ :argument-symbol 'xtm-id
+ :function-symbol 'make-pointer)))
(let ((identifier
(let ((existing-pointer
(remove-if
@@ -3396,8 +3595,11 @@
(destination-reified (reified-construct destination
:revision revision)))
(unless (eql (type-of source-reified) (type-of destination-reified))
- (error "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))
+ (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)))
(cond ((and source-reified destination-reified)
(delete-reifier source-reified source :revision revision)
(delete-reifier destination-reified destination :revision revision)
@@ -3551,8 +3753,11 @@
(parent-2 (parent newer-char :revision revision)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
+ (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)))
(cond ((and parent-1 (eql parent-1 parent-2))
(move-referenced-constructs newer-char older-char
:revision revision)
@@ -3585,10 +3790,12 @@
(let ((dst (if parent-1 older-char newer-char))
(src (if parent-1 newer-char older-char)))
(move-referenced-constructs src dst :revision revision)
+ (delete-if-not-referenced src)
dst))
(t
(move-referenced-constructs newer-char older-char
:revision revision)
+ (delete-if-not-referenced newer-char)
older-char)))))))
@@ -3622,8 +3829,11 @@
construct-1)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
+ (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)))
(move-referenced-constructs newer-assoc older-assoc)
(dolist (newer-role (roles newer-assoc :revision revision))
(let ((equivalent-role
@@ -3652,8 +3862,11 @@
construct-1)))
(unless (strictly-equivalent-constructs construct-1 construct-2
:revision revision)
- (error "From merge-constructs(): ~a and ~a are not mergable"
- construct-1 construct-2))
+ (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)))
(let ((parent-1 (parent older-role :revision revision))
(parent-2 (parent newer-role :revision revision)))
(cond ((and parent-1 (eql parent-1 parent-2))
@@ -3672,8 +3885,10 @@
(let ((dst (if parent-1 older-role newer-role))
(src (if parent-1 newer-role older-role)))
(move-referenced-constructs src dst :revision revision)
+ (delete-if-not-referenced src)
dst))
(t
(move-referenced-constructs newer-role older-role
:revision revision)
+ (delete-if-not-referenced newer-role)
older-role)))))))
\ No newline at end of file
Modified: branches/new-datamodel/src/model/exceptions.lisp
==============================================================================
--- branches/new-datamodel/src/model/exceptions.lisp (original)
+++ branches/new-datamodel/src/model/exceptions.lisp Thu Apr 8 05:55:12 2010
@@ -13,7 +13,10 @@
:missing-reference-error
:no-identifier-error
:duplicate-identifier-error
- :object-not-found-error))
+ :object-not-found-error
+ :not-mergable-error
+ :missing-argument-error
+ :tm-reference-error))
(in-package :exceptions)
@@ -22,6 +25,7 @@
:initarg :message
:accessor message)))
+
(define-condition missing-reference-error(error)
((message
:initarg :message
@@ -31,6 +35,7 @@
:initarg :reference))
(:documentation "thrown is a reference is missing"))
+
(define-condition duplicate-identifier-error(error)
((message
:initarg :message
@@ -40,12 +45,14 @@
:initarg :reference))
(:documentation "thrown if the same identifier is already in use"))
+
(define-condition object-not-found-error(error)
((message
:initarg :message
:accessor message))
(:documentation "thrown if the object could not be found"))
+
(define-condition no-identifier-error(error)
((message
:initarg :message
@@ -54,3 +61,48 @@
:initarg :internal-id
:accessor internal-id))
(:documentation "thrown if the topic has no identifier"))
+
+
+(define-condition not-mergable-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (construc-1
+ :initarg :construct-1
+ :accessor construct-1)
+ (construc-2
+ :initarg :construct-2
+ :accessor construct-2))
+ (:documentation "Thrown if two constructs are not mergable since
+ they have e.g. difference types."))
+
+
+(define-condition missing-argument-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (argument-symbol
+ :initarg :argument-symbol
+ :accessor argument-symbol)
+ (function-symbol
+ :initarg :function-symbol
+ :accessor function-symbol))
+ (:documentation "Thrown if a argument is missing in a function."))
+
+
+(define-condition tm-reference-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (referenced-construct
+ :initarg :referenced-construct
+ :accessor referenced-construct)
+ (existing-reference
+ :initarg :existing-reference
+ :accessor existing-reference)
+ (new-reference
+ :initarg :new-reference
+ :accessor new-reference))
+ (:documentation "Thrown of the referenced-construct is already owned by another
+ TM-construct (existing-reference) and is going to be referenced
+ by a second TM-construct (new-reference) at the same time."))
\ No newline at end of file
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Thu Apr 8 05:55:12 2010
@@ -15,7 +15,10 @@
:fixtures
:unittests-constants)
(:import-from :exceptions
- duplicate-identifier-error)
+ duplicate-identifier-error
+ missing-argument-error
+ tm-reference-error
+ object-not-found-error)
(:import-from :constants
*xml-string*
*xml-uri*)
@@ -166,7 +169,7 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct ii-1))
- (signals error (make-instance 'ItemIdentifierC))
+ (signals missing-argument-error (make-instance 'ItemIdentifierC))
(is-false (item-identifiers topic-1))
(add-item-identifier topic-1 ii-1)
(is (= (length (d::versions topic-1)) 1))
@@ -232,7 +235,7 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct psi-1))
- (signals error (make-instance 'PersistentIdC))
+ (signals missing-argument-error (make-instance 'PersistentIdC))
(is-false (psis topic-1))
(add-psi topic-1 psi-1)
(is (= (length (d::versions topic-1)) 1))
@@ -296,7 +299,7 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct sl-1))
- (signals error (make-instance 'SubjectLocatorC))
+ (signals missing-argument-error (make-instance 'SubjectLocatorC))
(is-false (locators topic-1))
(add-locator topic-1 sl-1)
(is (= (length (d::versions topic-1)) 1))
@@ -362,9 +365,9 @@
(revision-4 400))
(setf d:*TM-REVISION* revision-1)
(is-false (identified-construct ti-1))
- (signals error (make-instance 'TopicIdentificationC
+ (signals missing-argument-error (make-instance 'TopicIdentificationC
:uri "ti-1"))
- (signals error (make-instance 'TopicIdentificationC
+ (signals missing-argument-error (make-instance 'TopicIdentificationC
:xtm-id "xtm-id-1"))
(is-false (topic-identifiers topic-1))
(add-topic-identifier topic-1 ti-1)
@@ -436,11 +439,10 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-top-id" :revision rev-0))
- (signals error (is-false (get-item-by-id
- "any-top-id" :xtm-id "any-xtm-id"
- :error-if-nil t)))
- (signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t
- :revision rev-0)))
+ (signals object-not-found-error
+ (get-item-by-id "any-top-id" :xtm-id "any-xtm-id" :error-if-nil t))
+ (signals object-not-found-error
+ (get-item-by-id "any-top-id" :error-if-nil t :revision rev-0))
(is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id"))
(add-topic-identifier top-1 top-id-3-1 :revision rev-1)
(add-topic-identifier top-1 top-id-3-2 :revision rev-1)
@@ -497,12 +499,12 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-ii-id"))
- (signals error (is-false (get-item-by-item-identifier
- "any-ii-id" :error-if-nil t
- :revision rev-1)))
- (signals error (is-false (get-item-by-item-identifier
- "any-ii-id" :error-if-nil t
- :revision rev-1)))
+ (signals object-not-found-error
+ (get-item-by-item-identifier
+ "any-ii-id" :error-if-nil t :revision rev-1))
+ (signals object-not-found-error
+ (get-item-by-item-identifier
+ "any-ii-id" :error-if-nil t :revision rev-1))
(is-false (get-item-by-item-identifier "any-ii-id"))
(add-item-identifier top-1 ii-3-1 :revision rev-1)
(add-item-identifier top-1 ii-3-2 :revision rev-1)
@@ -542,12 +544,10 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-sl-id"))
- (signals error (is-false (get-item-by-locator
- "any-sl-id" :error-if-nil t
- :revision rev-0)))
- (signals error (is-false (get-item-by-locator
- "any-sl-id" :error-if-nil t
- :revision rev-0)))
+ (signals object-not-found-error
+ (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
+ (signals object-not-found-error
+ (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
(is-false (get-item-by-locator "any-sl-id" :revision rev-0))
(add-locator top-1 sl-3-1 :revision rev-1)
(add-locator top-1 sl-3-2 :revision rev-1)
@@ -587,12 +587,10 @@
(rev-2 200))
(setf d:*TM-REVISION* rev-1)
(is-false (get-item-by-id "any-psi-id"))
- (signals error (is-false (get-item-by-locator
- "any-psi-id" :error-if-nil t
- :revision rev-0)))
- (signals error (is-false (get-item-by-locator
- "any-psi-id" :error-if-nil t
- :revision rev-0)))
+ (signals object-not-found-error
+ (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0))
+ (signals object-not-found-error
+ (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0))
(is-false (get-item-by-locator "any-psi-id"))
(add-psi top-1 psi-3-1 :revision rev-1)
(add-psi top-1 psi-3-2 :revision rev-1)
@@ -699,7 +697,7 @@
(add-occurrence top-1 occ-1 :revision rev-4)
(is (= (length (union (list occ-2 occ-1)
(occurrences top-1 :revision rev-0))) 2))
- (signals error (add-occurrence top-2 occ-1 :revision rev-4))
+ (signals tm-reference-error (add-occurrence top-2 occ-1 :revision rev-4))
(delete-occurrence top-1 occ-1 :revision rev-5)
(is (= (length (union (list occ-2)
(occurrences top-1 :revision rev-5))) 1))
@@ -769,7 +767,7 @@
(add-variant name-1 v-1 :revision rev-4)
(is (= (length (union (list v-2 v-1)
(variants name-1 :revision rev-0))) 2))
- (signals error (add-variant name-2 v-1 :revision rev-4))
+ (signals tm-reference-error (add-variant name-2 v-1 :revision rev-4))
(delete-variant name-1 v-1 :revision rev-5)
(is (= (length (union (list v-2)
(variants name-1 :revision rev-5))) 1))
@@ -844,7 +842,7 @@
(add-name top-1 name-1 :revision rev-4)
(is (= (length (union (list name-2 name-1)
(names top-1 :revision rev-0))) 2))
- (signals error (add-name top-2 name-1 :revision rev-4))
+ (signals tm-reference-error (add-name top-2 name-1 :revision rev-4))
(delete-name top-1 name-1 :revision rev-5)
(is (= (length (union (list name-2)
(names top-1 :revision rev-5))) 1))
@@ -893,7 +891,7 @@
(is (eql top-1 (instance-of name-1)))
(is-false (instance-of name-1 :revision revision-0-5))
(is (eql top-1 (instance-of name-1 :revision revision-2)))
- (signals error (add-type name-1 top-2 :revision revision-0))
+ (signals tm-reference-error (add-type name-1 top-2 :revision revision-0))
(add-type name-2 top-1 :revision revision-2)
(is (= (length (union (list name-1 name-2)
(used-as-type top-1 :revision revision-0))) 2))
@@ -998,7 +996,7 @@
(is (eql (parent role-1 :revision rev-0) assoc-1))
(is (eql (parent role-2 :revision rev-2) assoc-1))
(is-false (parent role-2 :revision rev-1))
- (signals error (add-parent role-2 assoc-2 :revision rev-2))
+ (signals tm-reference-error (add-parent role-2 assoc-2 :revision rev-2))
(delete-role assoc-1 role-1 :revision rev-3)
(is (= (length (d::versions assoc-1)) 3))
(is-true (find-if #'(lambda(vi)
@@ -1056,7 +1054,7 @@
(is (eql top-1 (player role-1 :revision revision-0)))
(is-false (player role-1 :revision revision-0-5))
(is (eql top-1 (player role-1 :revision revision-2)))
- (signals error (add-player role-1 top-2))
+ (signals tm-reference-error (add-player role-1 top-2))
(add-player role-2 top-1 :revision revision-2)
(is (= (length (union (list role-1 role-2)
(player-in-roles top-1 :revision revision-0))) 2))
@@ -2097,11 +2095,12 @@
:start-revision rev-1
:identifier psi-1
:parent-construct top-1)))
- (signals error (make-construct 'd::PersistentIdAssociationC
- :start-revision rev-1
- :identifier psi-1))
+ (signals missing-argument-error
+ (make-construct 'd::PersistentIdAssociationC
+ :start-revision rev-1
+ :identifier psi-1))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'VersionedConstructC))
+ (signals missing-argument-error (make-construct 'VersionedConstructC))
(is (= (length (d::versions vc)) 1))
(is-true (find-if #'(lambda(vi)
(and (= (d::start-revision vi) rev-2)
@@ -2127,13 +2126,14 @@
:uri "tid-2" :xtm-id "xtm-id-2"
:identified-construct top-1
:start-revision rev-1)))
- (signals error (make-construct 'TopicIdentificationC
+ (signals missing-argument-error (make-construct 'TopicIdentificationC
:uri "uri"))
- (signals error (make-construct 'TopicIdentificationC
+ (signals missing-argument-error (make-construct 'TopicIdentificationC
:xtm-id "xtm-id"))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'TopicIdentificationC :uri "uri"
- :identified-construct top-1))
+ (signals missing-argument-error
+ (make-construct 'TopicIdentificationC :uri "uri"
+ :identified-construct top-1))
(is (string= (uri tid-1) "tid-1"))
(is (string= (xtm-id tid-1) "xtm-id-1"))
(is-false (d::slot-p tid-1 'd::identified-construct))
@@ -2168,8 +2168,8 @@
:identified-construct top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'PersistentIdC))
- (signals error (make-construct 'PersistentIdC :uri "uri"
+ (signals missing-argument-error (make-construct 'PersistentIdC))
+ (signals missing-argument-error (make-construct 'PersistentIdC :uri "uri"
:identified-construct top-1))
(is (string= (uri psi-1) "psi-1"))
(is-false (d::slot-p psi-1 'd::identified-construct))
@@ -2203,8 +2203,8 @@
:identified-construct top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'SubjectLocatorC))
- (signals error (make-construct 'SubjectLocatorC :uri "uri"
+ (signals missing-argument-error (make-construct 'SubjectLocatorC))
+ (signals missing-argument-error (make-construct 'SubjectLocatorC :uri "uri"
:identified-construct top-1))
(is (string= (uri sl-1) "sl-1"))
(is-false (d::slot-p sl-1 'd::identified-construct))
@@ -2238,8 +2238,8 @@
:identified-construct top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'ItemIdentifierC))
- (signals error (make-construct 'ItemIdentifierC :uri "uri"
+ (signals missing-argument-error (make-construct 'ItemIdentifierC))
+ (signals missing-argument-error (make-construct 'ItemIdentifierC :uri "uri"
:identified-construct top-1))
(is (string= (uri ii-1) "ii-1"))
(is-false (d::slot-p ii-1 'd::identified-construct))
@@ -2287,12 +2287,16 @@
:parent top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'OccurrenceC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'OccurrenceC :reifier reifier-1))
- (signals error (make-construct 'OccurrenceC :parent top-1))
- (signals error (make-construct 'OccurrenceC :instance-of type-1))
- (signals error (make-construct 'OccurrenceC :themes (list theme-1)))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :parent top-1))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :instance-of type-1))
+ (signals missing-argument-error
+ (make-construct 'OccurrenceC :themes (list theme-1)))
(is (string= (charvalue occ-1) ""))
(is (string= (datatype occ-1) *xml-string*))
(is-false (item-identifiers occ-1))
@@ -2344,13 +2348,18 @@
:parent top-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'NameC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'NameC :reifier reifier-1))
- (signals error (make-construct 'NameC :parent top-1))
- (signals error (make-construct 'NameC :instance-of type-1))
- (signals error (make-construct 'NameC :themes (list theme-1)))
- (signals error (make-construct 'NameC :variants (list variant-1)))
+ (signals missing-argument-error
+ (make-construct 'NameC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'NameC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'NameC :parent top-1))
+ (signals missing-argument-error
+ (make-construct 'NameC :instance-of type-1))
+ (signals missing-argument-error
+ (make-construct 'NameC :themes (list theme-1)))
+ (signals missing-argument-error
+ (make-construct 'NameC :variants (list variant-1)))
(is (string= (charvalue name-1) ""))
(is-false (item-identifiers name-1))
(is-false (reifier name-1))
@@ -2399,11 +2408,14 @@
:parent name-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'VariantC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'VariantC :reifier reifier-1))
- (signals error (make-construct 'VariantC :parent name-1))
- (signals error (make-construct 'VariantC :themes (list theme-1)))
+ (signals missing-argument-error
+ (make-construct 'VariantC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'VariantC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'VariantC :parent name-1))
+ (signals missing-argument-error
+ (make-construct 'VariantC :themes (list theme-1)))
(is (string= (charvalue variant-1) ""))
(is (string= (datatype variant-1) *xml-string*))
(is-false (item-identifiers variant-1))
@@ -2448,12 +2460,16 @@
:parent assoc-1
:start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'RoleC
- :item-identifiers (list ii-1)))
- (signals error (make-construct 'RoleC :reifier reifier-1))
- (signals error (make-construct 'RoleC :parent assoc-1))
- (signals error (make-construct 'RoleC :instance-of type-1))
- (signals error (make-construct 'RoleC :player player-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :item-identifiers (list ii-1)))
+ (signals missing-argument-error
+ (make-construct 'RoleC :reifier reifier-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :parent assoc-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :instance-of type-1))
+ (signals missing-argument-error
+ (make-construct 'RoleC :player player-1))
(is-false (item-identifiers role-1))
(is-false (reifier role-1))
(is-false (instance-of role-1))
@@ -2496,7 +2512,7 @@
:start-revision rev-1
:item-identifiers (list ii-3))))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'TopicMapC))
+ (signals missing-argument-error (make-construct 'TopicMapC))
(is (eql (reifier tm-1) reifier-1))
(is (= (length (item-identifiers tm-1)) 2))
(is (= (length (union (item-identifiers tm-1) (list ii-1 ii-2))) 2))
@@ -2566,12 +2582,12 @@
:roles (list role-1 role-2 role-2-2)))
(assoc-2 (make-construct 'AssociationC :start-revision rev-1)))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'AssociationC))
- (signals error (make-construct 'AssociationC
- :start-revision rev-1
- :roles (list
- (list :player player-1
- :instance-of r-type-1))))
+ (signals missing-argument-error (make-construct 'AssociationC))
+ (signals missing-argument-error
+ (make-construct 'AssociationC
+ :start-revision rev-1
+ :roles (list (list :player player-1
+ :instance-of r-type-1))))
(is (eql (instance-of assoc-1) type-1))
(is-true (themes assoc-1))
(is (= (length (union (list theme-1 theme-2) (themes assoc-1))) 2))
@@ -2684,7 +2700,7 @@
:names (list name-1)
:occurrences (list occ-1))))
(setf *TM-REVISION* rev-1)
- (signals error (make-construct 'TopicC))
+ (signals missing-argument-error (make-construct 'TopicC))
(is-false (item-identifiers top-1))
(is-false (psis top-1))
(is-false (locators top-1))
More information about the Isidorus-cvs
mailing list