[isidorus-cvs] r249 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Mar 23 18:45:50 UTC 2010
Author: lgiessmann
Date: Tue Mar 23 14:45:50 2010
New Revision: 249
Log:
new-datamodel: added unit-tests for "make-construct" corresponding to "OccurrenceC", "NameC" and "VariantC"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Mar 23 14:45:50 2010
@@ -981,16 +981,17 @@
(slot-p construct 'identified-construct)))))
(when assocs
(first assocs)))))
- (cond ((= revision 0)
- (find-most-recent-revision parent-assoc))
- (t
- (when (find-if
- #'(lambda(vi)
- (and (>= revision (start-revision vi))
- (or (< revision (end-revision vi))
- (= 0 (end-revision vi)))))
- (versions parent-assoc))
- construct))))
+ (when parent-assoc
+ (cond ((= revision 0)
+ (find-most-recent-revision parent-assoc))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct)))))
nil))
@@ -1754,18 +1755,19 @@
(slot-p construct 'parent)))))
(when assocs
(first assocs)))))
- (cond ((= revision 0)
- (when
- (find-most-recent-revision parent-assoc)
- construct))
- (t
- (when (find-if
- #'(lambda(vi)
- (and (>= revision (start-revision vi))
- (or (< revision (end-revision vi))
- (= 0 (end-revision vi)))))
- (versions parent-assoc))
- construct))))
+ (when parent-assoc
+ (cond ((= revision 0)
+ (when
+ (find-most-recent-revision parent-assoc)
+ construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct)))))
nil))
@@ -2084,29 +2086,32 @@
(defmethod find-item-by-revision ((construct RoleC)
(revision integer) &optional parent-construct)
- (let ((parent-assoc
- (let ((assocs
- (remove-if
- #'null
- (map 'list #'(lambda(assoc)
- (when (eql (parent-construct assoc)
- parent-construct)
- assoc))
- (slot-p construct 'parent)))))
- (when assocs
- (first assocs)))))
- (cond ((= revision 0)
- (when
- (find-most-recent-revision parent-assoc)
- construct))
- (t
- (when (find-if
- #'(lambda(vi)
- (and (>= revision (start-revision vi))
- (or (< revision (end-revision vi))
- (= 0 (end-revision vi)))))
- (versions parent-assoc))
- construct)))))
+ (if parent-construct
+ (let ((parent-assoc
+ (let ((assocs
+ (remove-if
+ #'null
+ (map 'list #'(lambda(assoc)
+ (when (eql (parent-construct assoc)
+ parent-construct)
+ assoc))
+ (slot-p construct 'parent)))))
+ (when assocs
+ (first assocs)))))
+ (when parent-assoc
+ (cond ((= revision 0)
+ (when
+ (find-most-recent-revision parent-assoc)
+ construct))
+ (t
+ (when (find-if
+ #'(lambda(vi)
+ (and (>= revision (start-revision vi))
+ (or (< revision (end-revision vi))
+ (= 0 (end-revision vi)))))
+ (versions parent-assoc))
+ construct)))))
+ nil))
(defmethod delete-construct :before ((construct RoleC))
@@ -2692,7 +2697,9 @@
history accordingly. Returns the object in question. Methods use
specific keyword arguments for their purpose."
(declare (symbol class-symbol))
- (when (and (VersionedConstructC-p class-symbol)
+ (when (and (or (VersionedConstructC-p class-symbol)
+ (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"))
(let ((construct
@@ -2714,7 +2721,7 @@
(rec-remf args :start-revision)))
(t
(apply #'make-instance class-symbol args))))
- (start-revision (getf args :start-revision)))
+ (start-revision (or (getf args :start-revision) *TM-REVISION*)))
(when (typep construct 'TypableC)
(complete-typable construct (getf args :instance-of)
:start-revision start-revision))
@@ -2724,7 +2731,7 @@
(when (typep construct 'VersionedConstructC)
(add-to-version-history construct :start-revision start-revision))
(if (typep construct 'ReifiableConstructC)
- (complete-reifiable construct (getf args :item-identtifiers)
+ (complete-reifiable construct (getf args :item-identifiers)
(getf args :reifier) :start-revision start-revision)
construct)))
@@ -2881,9 +2888,9 @@
To check if there is existing an equivalent construct the parameter
parent-construct must be set.
This function only exists for being used by make-construct!"
- (let ((charvalue (getf args :charvalue))
+ (let ((charvalue (or (getf args :charvalue) ""))
(start-revision (getf args :start-revision))
- (datatype (getf args :datatype))
+ (datatype (or (getf args :datatype) *xml-string*))
(instance-of (getf args :instance-of))
(themes (getf args :themes))
(variants (getf args :variants))
@@ -2909,7 +2916,8 @@
existing-characteristic
(make-instance class-symbol :charvalue charvalue
:datatype datatype)))))
- (complete-name characteristic variants :start-revision start-revision)
+ (when (typep characteristic 'NameC)
+ (complete-name characteristic variants :start-revision start-revision))
(when parent
(add-parent characteristic parent :revision start-revision))
characteristic)))
@@ -2922,9 +2930,15 @@
(let ((uri (getf args :uri))
(xtm-id (getf args :xtm-id))
(start-revision (getf args :start-revision))
- (identified-construct (getf args :identified-construct)))
+ (identified-construct (getf args :identified-construct))
+ (err "From make-pointer(): "))
(when (and identified-construct (not start-revision))
- (error "From make-pointer(): start-revision must be set"))
+ (error "~astart-revision must be set" err))
+ (unless uri
+ (error "~auri must be set" err))
+ (when (and (TopicIdentificationC-p class-symbol)
+ (not xtm-id))
+ (error "~axtm-id must be set" err))
(let ((identifier
(let ((existing-pointer
(remove-if
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Tue Mar 23 14:45:50 2010
@@ -65,7 +65,10 @@
:test-make-TopicIdentificationC
:test-make-PersistentIdC
:test-make-SubjectLocatorC
- :test-make-ItemIdentifierC))
+ :test-make-ItemIdentifierC
+ :test-make-OccurrenceC
+ :test-make-NameC
+ :test-make-VariantC))
;;TODO: test make-construct
@@ -1887,7 +1890,7 @@
:accessor value)))
(let ((construct (make-construct 'Unknown :value "value")))
(is-true construct)
- (string= (value construct) "value")))
+ (is (string= (value construct) "value"))))
(test test-make-VersionedConstructC ()
@@ -1933,6 +1936,10 @@
:uri "tid-2" :xtm-id "xtm-id-2"
:identified-construct top-1
:start-revision rev-1)))
+ (signals error (make-construct 'TopicIdentificationC
+ :uri "uri"))
+ (signals error (make-construct 'TopicIdentificationC
+ :xtm-id "xtm-id"))
(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))
@@ -1966,6 +1973,7 @@
:uri "psi-2"
:identified-construct top-1
:start-revision rev-1)))
+ (signals error (make-construct 'PersistentIdC))
(is (string= (uri psi-1) "psi-1"))
(is-false (d::slot-p psi-1 'd::identified-construct))
(is (string= (uri psi-2) "psi-2"))
@@ -1997,6 +2005,7 @@
:uri "sl-2"
:identified-construct top-1
:start-revision rev-1)))
+ (signals error (make-construct 'SubjectLocatorC))
(is (string= (uri sl-1) "sl-1"))
(is-false (d::slot-p sl-1 'd::identified-construct))
(is (string= (uri sl-2) "sl-2"))
@@ -2028,6 +2037,7 @@
:uri "ii-2"
:identified-construct top-1
:start-revision rev-1)))
+ (signals error (make-construct 'ItemIdentifierC))
(is (string= (uri ii-1) "ii-1"))
(is-false (d::slot-p ii-1 'd::identified-construct))
(is (string= (uri ii-2) "ii-2"))
@@ -2045,7 +2055,168 @@
(is (eql (identified-construct ii-2 :revision rev-1) top-1))
(is-false (identified-construct ii-2 :revision rev-0-5))
(is (eql (find-item-by-revision ii-2 rev-1 top-1) ii-2))))))
-
+
+
+(test test-make-OccurrenceC ()
+ "Tests the function make-construct corresponding to OccurrenceC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-0-5 50)
+ (rev-1 100)
+ (type-1 (make-instance 'TopicC))
+ (theme-1 (make-instance 'TopicC))
+ (theme-2 (make-instance 'TopicC))
+ (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+ (reifier-1 (make-instance 'TopicC))
+ (top-1 (make-instance 'TopicC)))
+ (setf *TM-REVISION* rev-1)
+ (let ((occ-1 (make-construct 'OccurrenceC))
+ (occ-2 (make-construct 'OccurrenceC
+ :charvalue "charvalue"
+ :datatype "datatype"
+ :item-identifiers (list ii-1 ii-2)
+ :reifier reifier-1
+ :instance-of type-1
+ :themes (list theme-1 theme-2)
+ :start-revision rev-1))
+ (occ-3 (make-construct 'OccurrenceC
+ :charvalue "charvalue-2"
+ :parent top-1
+ :start-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)))
+ (is (string= (charvalue occ-1) ""))
+ (is (string= (datatype occ-1) *xml-string*))
+ (is-false (item-identifiers occ-1))
+ (is-false (reifier occ-1))
+ (is-false (instance-of occ-1))
+ (is-false (themes occ-1))
+ (is-false (parent occ-1))
+ (is (string= (charvalue occ-2) "charvalue"))
+ (is (string= (datatype occ-2) "datatype"))
+ (is-true (item-identifiers occ-2))
+ (is (= (length (union (list ii-1 ii-2) (item-identifiers occ-2))) 2))
+ (is (eql (reifier occ-2) reifier-1))
+ (is (eql (instance-of occ-2) type-1))
+ (is-true (themes occ-2))
+ (is (= (length (union (list theme-1 theme-2) (themes occ-2))) 2))
+ (is-false (parent occ-2))
+ (is (eql ii-1 (find-item-by-revision ii-1 rev-1 occ-2)))
+ (is-false (item-identifiers occ-2 :revision rev-0-5))
+ (is (eql (parent occ-3) top-1))
+ (is (eql occ-3 (find-item-by-revision occ-3 rev-1 top-1)))))))
+
+
+(test test-make-NameC ()
+ "Tests the function make-construct corresponding to NameC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-0-5 50)
+ (rev-1 100)
+ (type-1 (make-instance 'TopicC))
+ (theme-1 (make-instance 'TopicC))
+ (theme-2 (make-instance 'TopicC))
+ (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+ (reifier-1 (make-instance 'TopicC))
+ (variant-1 (make-instance 'VariantC))
+ (variant-2 (make-instance 'VariantC))
+ (top-1 (make-instance 'TopicC)))
+ (setf *TM-REVISION* rev-1)
+ (let ((name-1 (make-construct 'NameC))
+ (name-2 (make-construct 'NameC
+ :charvalue "charvalue"
+ :variants (list variant-1 variant-2)
+ :item-identifiers (list ii-1 ii-2)
+ :reifier reifier-1
+ :instance-of type-1
+ :themes (list theme-1 theme-2)
+ :start-revision rev-1))
+ (name-3 (make-construct 'NameC
+ :charvalue "charvalue-2"
+ :parent top-1
+ :start-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)))
+ (is (string= (charvalue name-1) ""))
+ (is-false (item-identifiers name-1))
+ (is-false (reifier name-1))
+ (is-false (instance-of name-1))
+ (is-false (themes name-1))
+ (is-false (parent name-1))
+ (is-false (variants name-1))
+ (is (string= (charvalue name-2) "charvalue"))
+ (is-true (item-identifiers name-2))
+ (is (= (length (union (list ii-1 ii-2) (item-identifiers name-2))) 2))
+ (is (eql (reifier name-2) reifier-1))
+ (is (eql (instance-of name-2) type-1))
+ (is-true (themes name-2))
+ (is (= (length (union (list theme-1 theme-2) (themes name-2))) 2))
+ (is-true (variants name-2))
+ (is (= (length (union (list variant-1 variant-2) (variants name-2))) 2))
+ (is-false (parent name-2))
+ (is (eql ii-1 (find-item-by-revision ii-1 rev-1 name-2)))
+ (is-false (item-identifiers name-2 :revision rev-0-5))
+ (is (eql (parent name-3) top-1))
+ (is (eql name-3 (find-item-by-revision name-3 rev-1 top-1)))))))
+
+
+(test test-make-VariantC ()
+ "Tests the function make-construct corresponding to VariantC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((rev-0-5 50)
+ (rev-1 100)
+ (theme-1 (make-instance 'TopicC))
+ (theme-2 (make-instance 'TopicC))
+ (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
+ (reifier-1 (make-instance 'TopicC))
+ (name-1 (make-instance 'NameC)))
+ (setf *TM-REVISION* rev-1)
+ (let ((variant-1 (make-construct 'VariantC))
+ (variant-2 (make-construct 'VariantC
+ :charvalue "charvalue"
+ :datatype "datatype"
+ :item-identifiers (list ii-1 ii-2)
+ :reifier reifier-1
+ :themes (list theme-1 theme-2)
+ :start-revision rev-1))
+ (variant-3 (make-construct 'VariantC
+ :charvalue "charvalue-2"
+ :parent name-1
+ :start-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)))
+ (is (string= (charvalue variant-1) ""))
+ (is (string= (datatype variant-1) *xml-string*))
+ (is-false (item-identifiers variant-1))
+ (is-false (reifier variant-1))
+ (is-false (instance-of variant-1))
+ (is-false (themes variant-1))
+ (is-false (parent variant-1))
+ (is (string= (charvalue variant-2) "charvalue"))
+ (is (string= (datatype variant-2) "datatype"))
+ (is-true (item-identifiers variant-2))
+ (is (= (length (union (list ii-1 ii-2) (item-identifiers variant-2))) 2))
+ (is (eql (reifier variant-2) reifier-1))
+ (is-true (themes variant-2))
+ (is (= (length (union (list theme-1 theme-2) (themes variant-2))) 2))
+ (is-false (parent variant-2))
+ (is (eql ii-1 (find-item-by-revision ii-1 rev-1 variant-2)))
+ (is-false (item-identifiers variant-2 :revision rev-0-5))
+ (is (eql (parent variant-3) name-1))
+ (is (eql variant-3 (find-item-by-revision variant-3 rev-1 name-1)))))))
@@ -2098,4 +2269,7 @@
(it.bese.fiveam:run! 'test-make-PersistentIdC)
(it.bese.fiveam:run! 'test-make-SubjectLocatorC)
(it.bese.fiveam:run! 'test-make-ItemIdentifierC)
+ (it.bese.fiveam:run! 'test-make-OccurrenceC)
+ (it.bese.fiveam:run! 'test-make-NameC)
+ (it.bese.fiveam:run! 'test-make-VariantC)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list