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