[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