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))