March 2010 - isidorus-cvs@common-lisp.net

[isidorus-cvs] r229 - in trunk/src: json model rest_interface xml/rdf xml/xtm
by Lukas Giessmann 16 Mar '10

16 Mar '10

Author: lgiessmann Date: Tue Mar 16 18:24:22 2010 New Revision: 229 Log: fixed ticket #69 --> changed the mechanism of the json-reader and -writer, so there can be used with-reader-lock instead of with-writer-lock Modified: trunk/src/json/json_importer.lisp trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/xtm/setup.lisp Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Tue Mar 16 18:24:22 2010 @@ -32,13 +32,19 @@ (topicStubs-values (getf fragment-values :topicStubs)) (associations-values (getf fragment-values :associations)) (rev (get-revision))) ; creates a new revision, equal for all elements of the passed fragment - (elephant:ensure-transaction (:txn-nosync nil) - (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) - (loop for topicStub-values in (append topicStubs-values (list topic-values)) - do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) - (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) - (loop for association-values in associations-values - do (json-to-association association-values rev :tm xml-importer::tm)))))))) + (let ((psi-of-topic + (let ((psi-uris (getf topic-values :subjectIdentifiers))) + (when psi-uris + (first psi-uris))))) + (elephant:ensure-transaction (:txn-nosync nil) + (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) + (loop for topicStub-values in (append topicStubs-values (list topic-values)) + do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) + (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) + (loop for association-values in associations-values + do (json-to-association association-values rev :tm xml-importer::tm))) + (when psi-of-topic + (create-latest-fragment-of-topic psi-of-topic)))))))) (defun json-to-association (json-decoded-list start-revision Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp (original) +++ trunk/src/model/changes.lisp Tue Mar 16 18:24:22 2010 @@ -277,7 +277,7 @@ (defun create-latest-fragment-of-topic (topic-psi) - "returns the latest fragment of the passed topic-psi" + "Returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) (let ((topic (get-item-by-psi topic-psi))) @@ -299,4 +299,18 @@ :revision start-revision :associations (find-associations-for-topic topic) :referenced-topics (find-referenced-topics topic) - :topic topic))))))) \ No newline at end of file + :topic topic))))))) + + +(defun get-latest-fragment-of-topic (topic-psi) + "Returns the latest existing fragment of the passed topic-psi." + (declare (string topic-psi)) + (let ((topic + (get-item-by-psi topic-psi))) + (when topic + (let ((existing-fragments + (elephant:get-instances-by-value 'FragmentC 'topic topic))) + (when existing-fragments + (first (sort existing-fragments + #'(lambda(frg-1 frg-2) + (> (revision frg-1) (revision frg-2)))))))))) \ No newline at end of file Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Mar 16 18:24:22 2010 @@ -101,6 +101,7 @@ :variants :xor :create-latest-fragment-of-topic + :get-latest-fragment-of-topic :reified :reifier :add-reifier Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Tue Mar 16 18:24:22 2010 @@ -71,14 +71,20 @@ (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (setf atom:*base-url* (format nil "http://~a:~a" host-name port)) - (elephant:open-store - (xml-importer:get-store-spec repository-path)) + (unless elephant:*store-controller* + (elephant:open-store + (xml-importer:get-store-spec repository-path))) (load conffile) (publish-feed atom:*tm-feed*) (set-up-json-interface) (setf *server-acceptor* (make-instance 'hunchentoot:acceptor :address host-name :port port)) (setf hunchentoot:*lisp-errors-log-level* :info) (setf hunchentoot:*message-log-pathname* "./hunchentoot-errors.log") + (map 'list #'(lambda(top) + (let ((psis-of-top (psis top))) + (when psis-of-top + (create-latest-fragment-of-topic (uri (first psis-of-top)))))) + (elephant:get-instances-by-class 'd:TopicC)) (hunchentoot:start *server-acceptor*)) (defun shutdown-tm-engine () Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Tue Mar 16 18:24:22 2010 @@ -226,8 +226,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (to-json-string fragment)) @@ -251,8 +251,8 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (with-writer-lock - (create-latest-fragment-of-topic identifier)))) + (with-reader-lock + (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock (rdf-exporter:to-rdf-string fragment)) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Tue Mar 16 18:24:22 2010 @@ -20,9 +20,9 @@ (xml-importer:init-isidorus) (init-rdf-module) (rdf-importer rdf-xml-path repository-path :tm-id tm-id - :document-id document-id) - (when elephant:*store-controller* - (elephant:close-store))) + :document-id document-id)) +; (when elephant:*store-controller* +; (elephant:close-store))) (defun rdf-importer (rdf-xml-path repository-path @@ -46,7 +46,7 @@ (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" (length (elephant:get-instances-by-class 'TopicC)) (length (elephant:get-instances-by-class 'AssociationC))) - (elephant:close-store) +; (elephant:close-store) (setf *_n-map* nil))) Modified: trunk/src/xml/xtm/setup.lisp ============================================================================== --- trunk/src/xml/xtm/setup.lisp (original) +++ trunk/src/xml/xtm/setup.lisp Tue Mar 16 18:24:22 2010 @@ -50,6 +50,6 @@ (elephant:open-store (get-store-spec repository-path))) (init-isidorus) - (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format) - (when elephant:*store-controller* - (elephant:close-store))) \ No newline at end of file + (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)) +; (when elephant:*store-controller* +; (elephant:close-store))) \ No newline at end of file

1 0

[isidorus-cvs] r228 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 16 Mar '10

16 Mar '10

Author: lgiessmann Date: Tue Mar 16 08:56:24 2010 New Revision: 228 Log: new-datamodel: added some unit-tests for equivalent-construct --> RoleC, AssociationC, TopicC, TopicMapC; added equivalent-construct to TopicMapC; fixed a bug in equivalent-construct for all classes derived from ReifiableConstructC. 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 16 08:56:24 2010 @@ -649,9 +649,12 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) +(defgeneric equivalent-construct (construct &key start-revision + &allow-other-keys) (:documentation "Returns t if the passed construct is equivalent to the passed - key arguments (TMDM equality rules.")) + key arguments (TMDM equality rules. Parent-equality is not + checked in this methods, so the user has to pass children of + the same parent.")) (defgeneric get-most-recent-version-info (construct) @@ -786,6 +789,7 @@ ;;; PointerC (defmethod equivalent-construct ((construct PointerC) &key start-revision (uri "")) + "All Pointers are equal if they have the same URI value." (declare (string uri) (ignorable start-revision)) (string= (uri construct) uri)) @@ -815,6 +819,7 @@ ;;; TopicIdentificationC (defmethod equivalent-construct ((construct TopicIdentificationC) &key start-revision (uri "") (xtm-id "")) + "TopicIdentifiers are equal if teh URI and XTM-ID values are equal." (declare (string uri xtm-id)) (let ((equivalent-pointer (call-next-method construct :start-revision start-revision @@ -902,6 +907,11 @@ (defmethod equivalent-construct ((construct TopicC) &key (start-revision 0) (psis nil) (locators nil) (item-identifiers nil)) + "Isidorus handles Topic-equality only by the topic's identifiers + 'psis', 'subject locators' and 'item identifiers'. Names and occurences + are not checked becuase we don't know when a topic is finalized and owns + all its charactersitics. T is returned if the topic owns one of the given + identifier-URIs." (declare (integer start-revision) (list psis locators item-identifiers)) (when (intersection @@ -1356,8 +1366,8 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") (instance-of nil) (themes nil)) - "Equality rule: Characteristics are equal if charvalue, themes and the parent- - constructs are equal." + "Equality rule: Characteristics are equal if charvalue, themes and + instance-of are equal." (declare (string charvalue) (list themes item-identifiers) (integer start-revision) (type (or null TopicC) instance-of reifier)) @@ -1449,9 +1459,11 @@ (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil) (datatype "")) - (declare (type (or null TopicC) instance-of) (string datatype) - (ignorable start-revision charvalue themes instance-of - reifier item-identifiers)) + "Occurrences are equal if their charvalue, datatype, themes and + instance-of properties are equal." + (declare (type (or null TopicC) instance-of reifier) (string datatype) + (list item-identifiers) + (ignorable start-revision charvalue themes instance-of)) (let ((equivalent-characteristic (call-next-method))) (or (and equivalent-characteristic (string= (datatype construct) datatype)) @@ -1464,8 +1476,11 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") (themes nil) (datatype "")) - (declare (string datatype) (ignorable start-revision charvalue themes - reifier item-identifiers)) + "Variants are equal if their charvalue, datatype and themes + properties are equal." + (declare (string datatype) (list item-identifiers) + (ignorable start-revision charvalue themes) + (type (or null TopicC) reifier)) (let ((equivalent-characteristic (call-next-method))) (or (and equivalent-characteristic (string= (datatype construct) datatype)) @@ -1478,6 +1493,8 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil)) + "Names are equal if their charvalue, instance-of and themes properties + are equal." (declare (type (or null TopicC) instance-of) (ignorable start-revision charvalue instance-of themes reifier item-identifiers)) @@ -1548,6 +1565,8 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (roles nil) (instance-of nil) (themes nil)) + "Associations are equal if their themes, instance-of and roles + properties are equal." (declare (integer start-revision) (list roles themes item-identifiers) (type (or null TopicC) instance-of reifier)) (or @@ -1630,6 +1649,7 @@ &key (start-revision 0) (reifier nil) (item-identifiers nil) (player nil) (instance-of nil)) + "Roles are equal if their instance-of and player properties are equal." (declare (integer start-revision) (type (or null TopicC) player instance-of reifier) (list item-identifiers)) @@ -1764,7 +1784,9 @@ ;;; ReifiableConstructC (defgeneric equivalent-reifiable-construct (construct reifier item-identifiers &key start-revision) - (:documentation "Returns t if the passed constructs are TMDM equal.") + (:documentation "Returns t if the passed constructs are TMDM equal, i.e + the reifiable construct have to share an item identifier + or reifier.") (:method ((construct ReifiableConstructC) reifier item-identifiers &key (start-revision 0)) (declare (integer start-revision) (list item-identifiers) @@ -1904,7 +1926,8 @@ ;;; TypableC (defgeneric equivalent-typable-construct (construct instance-of &key start-revision) - (:documentation "Returns t if the passed constructs are TMDM equal.") + (:documentation "Returns t if the passed constructs are TMDM equal, i.e. + the typable constructs have to own the same type.") (:method ((construct TypableC) instance-of &key (start-revision 0)) (declare (integer start-revision) (type (or null TopicC) instance-of)) @@ -1913,7 +1936,8 @@ ;;; ScopableC (defgeneric equivalent-scopable-construct (construct themes &key start-revision) - (:documentation "Returns t if the passed constructs are TMDM equal.") + (:documentation "Returns t if the passed constructs are TMDM equal, i.e. + the scopable constructs have to own the same themes.") (:method ((construct ScopableC) themes &key (start-revision 0)) (declare (integer start-revision) (list themes)) (not (set-exclusive-or (themes construct :revision start-revision) @@ -2041,6 +2065,16 @@ ;;; TopicMapC +(defmethod equivalent-construct ((construct TopicMapC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil)) + "TopicMaps equality if they share the same item-identier or reifier." + (declare (list item-identifiers) (integer start-revision) + (type (or null TopicC) reifier)) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision)) + + (defmethod delete-construct :before ((construct TopicMapC)) (dolist (top (slot-p construct 'topics)) (remove-association construct 'topics top)) 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 16 08:56:24 2010 @@ -53,7 +53,11 @@ :test-equivalent-PointerC :test-equivalent-OccurrenceC :test-equivalent-NameC - :test-equivalent-VariantC)) + :test-equivalent-VariantC + :test-equivalent-RoleC + :test-equivalent-AssociationC + :test-equivalent-TopicC + :test-equivalent-TopicMapC)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1490,6 +1494,154 @@ (is-false (d::equivalent-construct var-1 :reifier reifier-2))))) +(test test-equivalent-RoleC () + "Tests the functions equivalent-construct depending on RoleC." + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'd:RoleC)) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (player-1 (make-instance 'd:TopicC)) + (player-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (ii-3 (make-instance 'd:ItemIdentifierC :uri "ii-3")) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-type role-1 type-1) + (add-player role-1 player-1) + (add-item-identifier role-1 ii-1) + (add-item-identifier role-1 ii-2) + (add-reifier role-1 reifier-1) + (is-true (d::equivalent-construct role-1 :player player-1 + :instance-of type-1)) + (is-true (d::equivalent-construct role-1 + :item-identifiers (list ii-1 ii-3))) + (is-true (d::equivalent-construct role-1 :reifier reifier-1)) + (is-false (d::equivalent-construct role-1 :player player-2 + :instance-of type-1)) + (is-false (d::equivalent-construct role-1 :player player-1 + :instance-of type-2)) + (is-false (d::equivalent-construct role-1 + :item-identifiers (list ii-3))) + (is-false (d::equivalent-construct role-1 :reifier reifier-2)) + (setf *TM-REVISION* revision-2) + (delete-item-identifier role-1 ii-1 :revision revision-2) + (delete-player role-1 player-1 :revision revision-2) + (add-player role-1 player-2) + (delete-type role-1 type-1 :revision revision-2) + (add-type role-1 type-2) + (delete-reifier role-1 reifier-1 :revision revision-2) + (add-reifier role-1 reifier-2) + (is-true (d::equivalent-construct role-1 :player player-2 + :instance-of type-2)) + (is-true (d::equivalent-construct role-1 + :item-identifiers (list ii-2))) + (is-true (d::equivalent-construct role-1 :reifier reifier-2)) + (is-false (d::equivalent-construct role-1 :player player-1 + :instance-of type-2)) + (is-false (d::equivalent-construct role-1 :player player-2 + :instance-of type-1)) + (is-false (d::equivalent-construct role-1 + :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct role-1 :reifier reifier-1)) + (is-true (d::equivalent-construct role-1 :start-revision revision-1 + :item-identifiers (list ii-1))) + (is-true (d::equivalent-construct role-1 :reifier reifier-1 + :start-revision revision-1))))) + + +(test test-equivalent-AssociationC () + "Tests the functions equivalent-construct depending on AssociationC." + (with-fixture with-empty-db (*db-dir*) + (let ((assoc-1 (make-instance 'd:AssociationC)) + (role-1 (make-instance 'd:RoleC)) + (role-2 (make-instance 'd:RoleC)) + (role-3 (make-instance 'd:RoleC)) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (d:add-role assoc-1 role-1) + (d:add-role assoc-1 role-2) + (d:add-type assoc-1 type-1) + (d:add-theme assoc-1 scope-1) + (d:add-theme assoc-1 scope-2) + (d:add-item-identifier assoc-1 ii-1) + (d:add-reifier assoc-1 reifier-1) + (is-true (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) :instance-of type-1 + :themes (list scope-1 scope-2))) + (is-true (d::equivalent-construct assoc-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct assoc-1 :reifier reifier-1)) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2 role-3) :instance-of type-1 + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) :instance-of type-2 + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list role-1 role-2) :instance-of type-1 + :themes (list scope-1 scope-3 scope-2))) + (is-false (d::equivalent-construct assoc-1 :item-identifiers (list ii-2))) + (is-false (d::equivalent-construct assoc-1 :reifeir reifier-2))))) + + +(test test-equivalent-TopicC () + "Tests the functions equivalent-construct depending on TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((top-1 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (sl-1 (make-instance 'd:SubjectLocatorC :uri "sl-1")) + (sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2")) + (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1")) + (psi-2 (make-instance 'd:PersistentIdC :uri "psi-2")) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (d:add-item-identifier top-1 ii-1) + (d:add-locator top-1 sl-1) + (d:add-psi top-1 psi-1) + (is-true (d::equivalent-construct top-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2) + :psis (list psi-1 psi-2) + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2))) + (is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2))) + (is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2) + :psis (list psi-2) + :locators (list sl-2)))))) + + +(test test-equivalent-TopicMapC () + "Tests the functions equivalent-construct depending on TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((tm-1 (make-instance 'd:TopicMapC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (d:add-item-identifier tm-1 ii-1) + (d:add-reifier tm-1 reifier-1) + (is-true (d::equivalent-construct tm-1 + :item-identifiers (list ii-1 ii-2))) + (is-true (d::equivalent-construct tm-1 :reifier reifier-1)) + (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2))) + (is-false (d::equivalent-construct tm-1 :reifier reifier-2))))) + (defun run-datamodel-tests() "Runs all tests of this test-suite." @@ -1527,4 +1679,8 @@ (it.bese.fiveam:run! 'test-equivalent-OccurrenceC) (it.bese.fiveam:run! 'test-equivalent-NameC) (it.bese.fiveam:run! 'test-equivalent-VariantC) + (it.bese.fiveam:run! 'test-equivalent-RoleC) + (it.bese.fiveam:run! 'test-equivalent-AssociationC) + (it.bese.fiveam:run! 'test-equivalent-TopicC) + (it.bese.fiveam:run! 'test-equivalent-TopicMapC) ) \ No newline at end of file

1 0

[isidorus-cvs] r227 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 16 Mar '10

16 Mar '10

Author: lgiessmann Date: Tue Mar 16 07:32:28 2010 New Revision: 227 Log: new-datamodel: added some unit-tests for equivalent-constructs --> OccurrenceC, NameC, VariantC; changed some "dangerous" code-sections in equivalent-construct 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 16 07:32:28 2010 @@ -1445,32 +1445,42 @@ ;;; OccurrenceC (defmethod equivalent-construct ((construct OccurrenceC) - &key (start-revision 0) (charvalue "") + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil) - (datatype *xml-string*)) + (datatype "")) (declare (type (or null TopicC) instance-of) (string datatype) - (ignorable start-revision charvalue themes instance-of)) + (ignorable start-revision charvalue themes instance-of + reifier item-identifiers)) (let ((equivalent-characteristic (call-next-method))) - (and equivalent-characteristic - (string= (datatype construct) datatype)))) + (or (and equivalent-characteristic + (string= (datatype construct) datatype)) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision)))) ;;; VariantC (defmethod equivalent-construct ((construct VariantC) - &key (start-revision 0) (charvalue "") - (themes nil) (datatype *xml-string*)) - (declare (string datatype) (ignorable start-revision charvalue themes)) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") + (themes nil) (datatype "")) + (declare (string datatype) (ignorable start-revision charvalue themes + reifier item-identifiers)) (let ((equivalent-characteristic (call-next-method))) - (and equivalent-characteristic - (string= (datatype construct) datatype)))) + (or (and equivalent-characteristic + (string= (datatype construct) datatype)) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision)))) ;;; NameC (defmethod equivalent-construct ((construct NameC) - &key (start-revision 0) (charvalue "") + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") (themes nil) (instance-of nil)) (declare (type (or null TopicC) instance-of) - (ignorable start-revision charvalue instance-of themes)) + (ignorable start-revision charvalue instance-of themes + reifier item-identifiers)) (call-next-method)) @@ -1759,9 +1769,11 @@ &key (start-revision 0)) (declare (integer start-revision) (list item-identifiers) (type (or null TopicC) reifier)) - (or (eql reifier (reifier construct :revision start-revision)) - (intersection (item-identifiers construct :revision start-revision) - item-identifiers)))) + (or (and (reifier construct :revision start-revision) + (eql reifier (reifier construct :revision start-revision))) + (and (item-identifiers construct :revision start-revision) + (intersection (item-identifiers construct :revision start-revision) + item-identifiers))))) (defmethod delete-construct :before ((construct ReifiableConstructC)) 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 16 07:32:28 2010 @@ -16,6 +16,8 @@ :unittests-constants) (:import-from :exceptions duplicate-identifier-error) + (:import-from :constants + *xml-string*) (:export :run-datamodel-tests :datamodel-test :test-VersionInfoC @@ -48,7 +50,10 @@ :test-delete-ScopableC :test-delete-AssociationC :test-delete-RoleC - :test-equivalent-PointerC)) + :test-equivalent-PointerC + :test-equivalent-OccurrenceC + :test-equivalent-NameC + :test-equivalent-VariantC)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1356,6 +1361,136 @@ (is-false (d::equivalent-construct psi-1 :uri "psi-2"))))) +(test test-equivalent-OccurrenceC () + "Tests the functions equivalent-construct depending on OccurrenceC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'd:OccurrenceC :charvalue "occ-1")) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (revision-0-5 50) + (version-1 100)) + (setf *TM-REVISION* version-1) + (add-type occ-1 type-1) + (add-theme occ-1 scope-1) + (add-theme occ-1 scope-2) + (is-true (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-2 scope-1) + :start-revision revision-0-5)) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-2 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-1" + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + occ-1 :charvalue "occ-2" :datatype constants:*xml-string* + :instance-of type-1 :themes (list scope-2 scope-1))) + (add-item-identifier occ-1 ii-1) + (is-true (d::equivalent-construct occ-1 :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct occ-1 :item-identifiers (list ii-2))) + (add-reifier occ-1 reifier-1) + (is-true (d::equivalent-construct occ-1 :reifier reifier-1)) + (is-false (d::equivalent-construct occ-1 :reifier reifier-2))))) + + +(test test-equivalent-NameC () + "Tests the functions equivalent-construct depending on NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((nam-1 (make-instance 'd:NameC :charvalue "nam-1")) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (revision-0-5 50) + (version-1 100)) + (setf *TM-REVISION* version-1) + (add-type nam-1 type-1) + (add-theme nam-1 scope-1) + (add-theme nam-1 scope-2) + (is-true (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-1 + :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-1 + :themes (list scope-2 scope-1) + :start-revision revision-0-5)) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-2 + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-1" :instance-of type-1 + :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + nam-1 :charvalue "nam-2" :instance-of type-1 + :themes (list scope-2 scope-1))) + (add-item-identifier nam-1 ii-1) + (is-true (d::equivalent-construct nam-1 :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct nam-1 :item-identifiers (list ii-2))) + (add-reifier nam-1 reifier-1) + (is-true (d::equivalent-construct nam-1 :reifier reifier-1)) + (is-false (d::equivalent-construct nam-1 :reifier reifier-2))))) + + +(test test-equivalent-VariantC () + "Tests the functions equivalent-construct depending on VariantC." + (with-fixture with-empty-db (*db-dir*) + (let ((var-1 (make-instance 'd:OccurrenceC :charvalue "var-1")) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC)) + (reifier-1 (make-instance 'd:TopicC)) + (reifier-2 (make-instance 'd:TopicC)) + (ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) + (revision-0-5 50) + (version-1 100)) + (setf *TM-REVISION* version-1) + (add-theme var-1 scope-1) + (add-theme var-1 scope-2) + (is-true (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-2 scope-1))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-2 scope-1) + :start-revision revision-0-5)) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" :datatype constants:*xml-string* + :themes (list scope-3 scope-2))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-1" + :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + var-1 :charvalue "var-2" :datatype constants:*xml-string* + :themes (list scope-2 scope-1))) + (add-item-identifier var-1 ii-1) + (is-true (d::equivalent-construct var-1 :item-identifiers (list ii-1))) + (is-false (d::equivalent-construct var-1 :item-identifiers (list ii-2))) + (add-reifier var-1 reifier-1) + (is-true (d::equivalent-construct var-1 :reifier reifier-1)) + (is-false (d::equivalent-construct var-1 :reifier reifier-2))))) + + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -1389,4 +1524,7 @@ (it.bese.fiveam:run! 'test-delete-AssociationC) (it.bese.fiveam:run! 'test-delete-RoleC) (it.bese.fiveam:run! 'test-equivalent-PointerC) + (it.bese.fiveam:run! 'test-equivalent-OccurrenceC) + (it.bese.fiveam:run! 'test-equivalent-NameC) + (it.bese.fiveam:run! 'test-equivalent-VariantC) ) \ No newline at end of file

1 0

[isidorus-cvs] r226 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 14 Mar '10

14 Mar '10

Author: lgiessmann Date: Sun Mar 14 16:28:40 2010 New Revision: 226 Log: new-datamodel: added some unit-tests for equivalent-construct depending on PointerC 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 Sun Mar 14 16:28:40 2010 @@ -1362,9 +1362,10 @@ (integer start-revision) (type (or null TopicC) instance-of reifier)) (or (and (string= (charvalue construct) charvalue) - (not (set-exclusive-or (themes construct :revision start-revision) - themes)) - (eql instance-of (instance-of construct :revision start-revision))) + (equivalent-scopable-construct construct themes + :start-revision start-revision) + (equivalent-typable-construct construct instance-of + :start-revision start-revision)) (equivalent-reifiable-construct construct reifier item-identifiers :start-revision start-revision))) @@ -1542,9 +1543,10 @@ (or (and (not (set-exclusive-or roles (roles construct :revision start-revision))) - (eql instance-of (instance-of construct :revision start-revision)) - (not (set-exclusive-or themes - (themes construct :revision start-revision)))) + (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (equivalent-scopable-construct construct themes + :start-revision start-revision)) (equivalent-reifiable-construct construct reifier item-identifiers :start-revision start-revision))) @@ -1621,7 +1623,8 @@ (declare (integer start-revision) (type (or null TopicC) player instance-of reifier) (list item-identifiers)) - (or (and (eql instance-of (instance-of construct :revision start-revision)) + (or (and (equivalent-typable-construct construct instance-of + :start-revision start-revision) (eql player (player construct :revision start-revision))) (equivalent-reifiable-construct construct reifier item-identifiers :start-revision start-revision))) @@ -1886,8 +1889,25 @@ (mark-as-deleted assoc-to-delete :revision revision)) construct))) +;;; TypableC +(defgeneric equivalent-typable-construct (construct instance-of + &key start-revision) + (:documentation "Returns t if the passed constructs are TMDM equal.") + (:method ((construct TypableC) instance-of &key (start-revision 0)) + (declare (integer start-revision) + (type (or null TopicC) instance-of)) + (eql (instance-of construct :revision start-revision) instance-of))) + ;;; ScopableC +(defgeneric equivalent-scopable-construct (construct themes &key start-revision) + (:documentation "Returns t if the passed constructs are TMDM equal.") + (:method ((construct ScopableC) themes &key (start-revision 0)) + (declare (integer start-revision) (list themes)) + (not (set-exclusive-or (themes construct :revision start-revision) + themes)))) + + (defmethod delete-construct :before ((construct ScopableC)) (dolist (scope-assoc-to-delete (slot-p construct 'themes)) (delete-construct scope-assoc-to-delete))) 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 Sun Mar 14 16:28:40 2010 @@ -47,7 +47,8 @@ :test-delete-TypableC :test-delete-ScopableC :test-delete-AssociationC - :test-delete-RoleC)) + :test-delete-RoleC + :test-equivalent-PointerC)) ;;TODO: test merge-constructs when merging was caused by an item-dentifier, @@ -1337,6 +1338,24 @@ (is-false (elephant:get-instances-by-class 'd::PlayerAssociationC))))) +(test test-equivalent-PointerC () + "Tests the functions equivalent-construct depending on PointerC + and its subclasses." + (with-fixture with-empty-db (*db-dir*) + (let ((p-1 (make-instance 'd::PointerC :uri "p-1")) + (tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (psi-1 (make-instance 'd:PersistentIdC :uri "psi-1"))) + (is-true (d::equivalent-construct p-1 :uri "p-1")) + (is-false (d::equivalent-construct p-1 :uri "p-2")) + (is-true (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-1")) + (is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-1")) + (is-false (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-2")) + (is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-2")) + (is-true (d::equivalent-construct psi-1 :uri "psi-1")) + (is-false (d::equivalent-construct psi-1 :uri "psi-2"))))) + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -1369,4 +1388,5 @@ (it.bese.fiveam:run! 'test-delete-ScopableC) (it.bese.fiveam:run! 'test-delete-AssociationC) (it.bese.fiveam:run! 'test-delete-RoleC) + (it.bese.fiveam:run! 'test-equivalent-PointerC) ) \ No newline at end of file

1 0

[isidorus-cvs] r225 - branches/new-datamodel/src/model
by Lukas Giessmann 14 Mar '10

14 Mar '10

Author: lgiessmann Date: Sun Mar 14 11:50:40 2010 New Revision: 225 Log: new-datamodel: added "equivalent-costruct" to PointerC, TopicIdentificationC, CharactersiticC, OccurrenceC, NameC, VariantC, RoleC, AssociationC, TopicC Modified: branches/new-datamodel/src/model/datamodel.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Mar 14 11:50:40 2010 @@ -12,6 +12,8 @@ (:nicknames :d) (:import-from :exceptions duplicate-identifier-error) + (:import-from :constants + *xml-string*) (:export ;;classes :TopicMapC :AssociationC @@ -77,6 +79,7 @@ :used-as-type :used-as-theme :datatype + :charvalue :reified-construct :mark-as-deleted :mark-as-deleted-p @@ -97,7 +100,6 @@ (in-package :datamodel) -;;TODO: implement delete-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -186,9 +188,9 @@ :initarg :datatype :initform constants:*xml-string* :type string + :index t :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef).")) - (:index t) (:documentation "An abstract base class for characteristics that own an xml-datatype.")) @@ -581,6 +583,17 @@ (error () nil)))) +(defun make-construct (class-symbol &key start-revision &allow-other-keys) + "Creates a new topic map construct if necessary or + retrieves an equivalent one if available and updates the revision + history accordingly. Returns the object in question. Methods use + specific keyword arguments for their purpose." + (or class-symbol start-revision) + ;TODO: implement + ) + + + (defun delete-1-n-association(instance slot-symbol) (when (slot-p instance slot-symbol) (remove-association @@ -635,6 +648,39 @@ (condition () nil))) +;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) + (:documentation "Returns t if the passed construct is equivalent to the passed + key arguments (TMDM equality rules.")) + + +(defgeneric get-most-recent-version-info (construct) + (:documentation "Returns the latest VersionInfoC object of the passed + versioned construct. + The latest construct is either the one with + end-revision=0 or with the highest end-revision value.")) + + +(defgeneric owned-p (construct) + (:documentation "Returns t if the passed construct is referenced by a parent + TM construct.")) + + +(defgeneric in-topicmaps (construct &key revision) + (:documentation "Returns all TopicMapS-obejcts where the constrict is + contained in.")) + + +(defgeneric add-to-tm (construct construct-to-add) + (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) + + +(defgeneric delete-from-tm (construct construct-to-delete) + (:documentation "Deletes a TM construct (TopicC or AssociationC) from + the TM.")) + + + ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VersionInfocC (defmethod delete-construct :before ((version-info VersionInfoC)) @@ -647,13 +693,6 @@ (delete-construct version-info))) -(defgeneric get-most-recent-version-info (construct) - (:documentation "Returns the latest VersionInfoC object of the passed - versioned construct. - The latest construct is either the one with - end-revision=0 or with the highest end-revision value.")) - - (defmethod get-most-recent-version-info ((construct VersionedConstructC)) (let ((result (find 0 (versions construct) :key #'end-revision))) (if result @@ -690,38 +729,36 @@ (defgeneric add-to-version-history (construct &key start-revision end-revision) - (:documentation "Adds version history to a versioned construct")) - - -(defmethod add-to-version-history ((construct VersionedConstructC) - &key (start-revision (error "From add-to-version-history(): start revision must be present")) - (end-revision 0)) - (let ((eql-version-info - (find-if #'(lambda(vi) - (and (= (start-revision vi) start-revision) - (= (end-revision vi) end-revision))) - (versions construct)))) - (if eql-version-info - eql-version-info - (let ((current-version-info - (get-most-recent-version-info construct))) - (cond - ((and current-version-info - (= (end-revision current-version-info) start-revision)) - (setf (end-revision current-version-info) 0) - current-version-info) - ((and current-version-info - (= (end-revision current-version-info) 0)) - (setf (end-revision current-version-info) start-revision) - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)) - (t - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct))))))) + (: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")) + (end-revision 0)) + (let ((eql-version-info + (find-if #'(lambda(vi) + (and (= (start-revision vi) start-revision) + (= (end-revision vi) end-revision))) + (versions construct)))) + (if eql-version-info + eql-version-info + (let ((current-version-info + (get-most-recent-version-info construct))) + (cond + ((and current-version-info + (= (end-revision current-version-info) start-revision)) + (setf (end-revision current-version-info) 0) + current-version-info) + ((and current-version-info + (= (end-revision current-version-info) 0)) + (setf (end-revision current-version-info) start-revision) + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct)) + (t + (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision + :versioned-construct construct)))))))) (defgeneric marked-as-deleted-p (construct) @@ -736,32 +773,28 @@ (defgeneric mark-as-deleted (construct &key source-locator revision) (:documentation "Mark a construct as deleted if it comes from the source - indicated by source-locator")) - + indicated by source-locator") + (:method ((construct VersionedConstructC) &key source-locator revision) + (declare (ignorable source-locator)) + (let + ((last-version ;the last active version + (find 0 (versions construct) :key #'end-revision))) + (when last-version + (setf (end-revision last-version) revision))))) + -(defmethod mark-as-deleted ((construct VersionedConstructC) - &key source-locator revision) - "Mark a topic as deleted if it comes from the source indicated by - source-locator" - (declare (ignorable source-locator)) - (let - ((last-version ;the last active version - (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision)))) +;;; PointerC +(defmethod equivalent-construct ((construct PointerC) + &key start-revision (uri "")) + (declare (string uri) (ignorable start-revision)) + (string= (uri construct) uri)) -;;; PointerC (defmethod delete-construct :before ((construct PointerC)) (dolist (p-assoc (slot-p construct 'identified-construct)) (delete-construct p-assoc))) -(defgeneric owned-p (construct) - (:documentation "Returns t if the passed construct is referenced by a parent - TM construct.")) - - (defmethod owned-p ((construct PointerC)) (when (slot-p construct 'identified-construct) t)) @@ -779,6 +812,17 @@ (first assocs))))) +;;; TopicIdentificationC +(defmethod equivalent-construct ((construct TopicIdentificationC) + &key start-revision (uri "") (xtm-id "")) + (declare (string uri xtm-id)) + (let ((equivalent-pointer (call-next-method + construct :start-revision start-revision + :uri uri))) + (and equivalent-pointer + (string= (xtm-id construct) xtm-id)))) + + ;;; PointerAssociationC (defmethod delete-construct :before ((construct PointerAssociationC)) (delete-1-n-association construct 'identifier)) @@ -855,6 +899,19 @@ ;;; TopicC +(defmethod equivalent-construct ((construct TopicC) + &key (start-revision 0) (psis nil) + (locators nil) (item-identifiers nil)) + (declare (integer start-revision) (list psis locators item-identifiers)) + (when + (intersection + (union (union (psis construct :revision start-revision) + (locators construct :revision start-revision)) + (item-identifiers construct :revision start-revision)) + (union (union psis locators) item-identifiers)) + t)) + + (defmethod delete-construct :before ((construct TopicC)) (let ((psi-assocs-to-delete (slot-p construct 'psis)) (sl-assocs-to-delete (slot-p construct 'locators)) @@ -1193,10 +1250,6 @@ (reifiable-construct (first assocs)))))) -(defgeneric in-topicmaps (construct &key revision) - (:documentation "Returns all TopicMapS-obejcts where the constrict is - contained in.")) - (defmethod in-topicmaps ((topic TopicC) &key (revision 0)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) @@ -1298,67 +1351,24 @@ :error-if-nil error-if-nil)) -;;; NameC -(defmethod delete-construct :before ((construct NameC)) - (let ((variant-assocs-to-delete (slot-p construct 'variants))) - (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) - (dolist (variant-assoc-to-delete variant-assocs-to-delete) - (delete-construct variant-assoc-to-delete)) - (dolist (candidate-to-delete all-variants) - (unless (owned-p candidate-to-delete) - (delete-construct candidate-to-delete)))))) - - -(defgeneric variants (construct &key revision) - (:documentation "Returns all variants that correspond with the given revision - and that are associated with the passed construct.") - (:method ((construct NameC) &key (revision 0)) - (let ((valid-associations - (filter-slot-value-by-revision construct 'variants - :start-revision revision))) - (map 'list #'characteristic valid-associations)))) - - -(defgeneric add-variant (construct variant &key revision) - (:documentation "Adds the given theme-topic to the passed - scopable-construct.") - (:method ((construct NameC) (variant VariantC) - &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))) - (let ((all-variants - (map 'list #'characteristic (slot-p construct 'variants)))) - (if (find variant all-variants) - (let ((variant-assoc - (loop for variant-assoc in (slot-p construct 'variants) - when (eql (characteristic variant-assoc) variant) - return variant-assoc))) - (add-to-version-history variant-assoc :start-revision revision)) - (let ((assoc - (make-instance 'VariantAssociationC - :characteristic variant - :parent-construct construct))) - (add-to-version-history assoc :start-revision revision)))) - construct)) - - -(defgeneric delete-variant (construct variant &key revision) - (: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"))) - (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct - 'variants) - when (eql (characteristic variant-assoc) variant) - return variant-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct))) +;;; CharacteristicC +(defmethod equivalent-construct ((construct CharacteristicC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (charvalue "") + (instance-of nil) (themes nil)) + "Equality rule: Characteristics are equal if charvalue, themes and the parent- + constructs are equal." + (declare (string charvalue) (list themes item-identifiers) + (integer start-revision) + (type (or null TopicC) instance-of reifier)) + (or (and (string= (charvalue construct) charvalue) + (not (set-exclusive-or (themes construct :revision start-revision) + themes)) + (eql instance-of (instance-of construct :revision start-revision))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) -;;; CharacteristicC (defmethod delete-construct :before ((construct CharacteristicC)) (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) (delete-construct characteristic-assoc-to-delete))) @@ -1432,7 +1442,113 @@ construct))) +;;; OccurrenceC +(defmethod equivalent-construct ((construct OccurrenceC) + &key (start-revision 0) (charvalue "") + (themes nil) (instance-of nil) + (datatype *xml-string*)) + (declare (type (or null TopicC) instance-of) (string datatype) + (ignorable start-revision charvalue themes instance-of)) + (let ((equivalent-characteristic (call-next-method))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; VariantC +(defmethod equivalent-construct ((construct VariantC) + &key (start-revision 0) (charvalue "") + (themes nil) (datatype *xml-string*)) + (declare (string datatype) (ignorable start-revision charvalue themes)) + (let ((equivalent-characteristic (call-next-method))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; NameC +(defmethod equivalent-construct ((construct NameC) + &key (start-revision 0) (charvalue "") + (themes nil) (instance-of nil)) + (declare (type (or null TopicC) instance-of) + (ignorable start-revision charvalue instance-of themes)) + (call-next-method)) + + +(defmethod delete-construct :before ((construct NameC)) + (let ((variant-assocs-to-delete (slot-p construct 'variants))) + (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) + (dolist (variant-assoc-to-delete variant-assocs-to-delete) + (delete-construct variant-assoc-to-delete)) + (dolist (candidate-to-delete all-variants) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete)))))) + + +(defgeneric variants (construct &key revision) + (:documentation "Returns all variants that correspond with the given revision + and that are associated with the passed construct.") + (:method ((construct NameC) &key (revision 0)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'variants + :start-revision revision))) + (map 'list #'characteristic valid-associations)))) + + +(defgeneric add-variant (construct variant &key revision) + (:documentation "Adds the given theme-topic to the passed + scopable-construct.") + (:method ((construct NameC) (variant VariantC) + &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))) + (let ((all-variants + (map 'list #'characteristic (slot-p construct 'variants)))) + (if (find variant all-variants) + (let ((variant-assoc + (loop for variant-assoc in (slot-p construct 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (add-to-version-history variant-assoc :start-revision revision)) + (let ((assoc + (make-instance 'VariantAssociationC + :characteristic variant + :parent-construct construct))) + (add-to-version-history assoc :start-revision revision)))) + construct)) + + +(defgeneric delete-variant (construct variant &key revision) + (: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"))) + (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct + 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) + + ;;; AssociationC +(defmethod equivalent-construct ((construct AssociationC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (roles nil) + (instance-of nil) (themes nil)) + (declare (integer start-revision) (list roles themes item-identifiers) + (type (or null TopicC) instance-of reifier)) + (or + (and + (not (set-exclusive-or roles (roles construct :revision start-revision))) + (eql instance-of (instance-of construct :revision start-revision)) + (not (set-exclusive-or themes + (themes construct :revision start-revision)))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) + + (defmethod delete-construct :before ((construct AssociationC)) (let ((roles-assocs-to-delete (slot-p construct 'roles))) (let ((all-roles (map 'list #'role roles-assocs-to-delete))) @@ -1498,6 +1614,19 @@ ;;; RoleC +(defmethod equivalent-construct ((construct RoleC) + &key (start-revision 0) (reifier nil) + (item-identifiers nil) (player nil) + (instance-of nil)) + (declare (integer start-revision) + (type (or null TopicC) player instance-of reifier) + (list item-identifiers)) + (or (and (eql instance-of (instance-of construct :revision start-revision)) + (eql player (player construct :revision start-revision))) + (equivalent-reifiable-construct construct reifier item-identifiers + :start-revision start-revision))) + + (defmethod delete-construct :before ((construct RoleC)) (dolist (role-assoc-to-delete (slot-p construct 'parent)) (delete-construct role-assoc-to-delete)) @@ -1620,6 +1749,18 @@ ;;; ReifiableConstructC +(defgeneric equivalent-reifiable-construct (construct reifier item-identifiers + &key start-revision) + (:documentation "Returns t if the passed constructs are TMDM equal.") + (:method ((construct ReifiableConstructC) reifier item-identifiers + &key (start-revision 0)) + (declare (integer start-revision) (list item-identifiers) + (type (or null TopicC) reifier)) + (or (eql reifier (reifier construct :revision start-revision)) + (intersection (item-identifiers construct :revision start-revision) + item-identifiers)))) + + (defmethod delete-construct :before ((construct ReifiableConstructC)) (let ((ii-assocs-to-delete (slot-p construct 'item-identifiers)) (reifier-assocs-to-delete (slot-p construct 'reifier))) @@ -1889,10 +2030,6 @@ :start-revision revision))) -(defgeneric add-to-tm (construct construct-to-add) - (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) - - (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) (add-association construct 'topics construct-to-add)) @@ -1901,11 +2038,6 @@ (add-association construct 'associations construct-to-add)) -(defgeneric delete-from-tm (construct construct-to-delete) - (:documentation "Deletes a TM construct (TopicC or AssociationC) from - the TM.")) - - (defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) (remove-association construct 'topics construct-to-delete)) @@ -1923,15 +2055,22 @@ + + + + + + + + + + + + ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric merge-constructs(construct-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) &key (revision *TM-REVISION*)) (or revision) (if construct-1 construct-1 construct-2))) - - -(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys) - (:method ((class-symbol symbol) &key (start-revision *TM-REVISION*)) - (or class-symbol start-revision))) ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file

1 0

[isidorus-cvs] r224 - branches/new-datamodel/playground
by Lukas Giessmann 13 Mar '10

13 Mar '10

Author: lgiessmann Date: Sat Mar 13 16:09:24 2010 New Revision: 224 Log: new-datamodel: added a new sample file for call-next-mehtod in a multiple-inheritance scenario Added: branches/new-datamodel/playground/call-next-method_multiple-inheritance.lisp Added: branches/new-datamodel/playground/call-next-method_multiple-inheritance.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/call-next-method_multiple-inheritance.lisp Sat Mar 13 16:09:24 2010 @@ -0,0 +1,31 @@ +(defclass CharacteristicC() + ((value :accessor value + :initarg :value + :type string))) + +(defclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :type string))) + +(defclass OccurrenceC (CharacteristicC DatatypableC) + ()) + +(defgeneric equivalent-construct (construct &rest args)) + +(defmethod equivalent-construct ((construct OccurrenceC) &rest args) + (format t "equivalent-construct --> OccurrenceC: ~a~%" args) + (call-next-method construct args)) + +(defmethod equivalent-construct ((construct CharacteristicC) &rest args) + (format t "equivalent-construct --> CharacteristicC: ~a~%" args) + (call-next-method construct (first args)) + (string= (value construct) (getf (first args) :value))) + +(defmethod equivalent-construct ((construct DatatypableC) &rest args) + (format t "equivalent-construct --> DatatypableC: ~a~%" args) + (string= (datatype construct) (getf (first args) :datatype))) + +(defvar *occ* (make-instance 'Occurrencec :value "value" :datatype "datatype")) + +(equivalent-construct *occ* :value "value" :datatype "datatype")

1 0

[isidorus-cvs] r223 - branches/new-datamodel/playground
by Lukas Giessmann 10 Mar '10

10 Mar '10

Author: lgiessmann Date: Wed Mar 10 11:59:11 2010 New Revision: 223 Log: new-datamodel: added a sample file that handles "call-next-method" and the auxiliary methods (":before", "after" and "around") Added: branches/new-datamodel/playground/call-next-method.lisp Added: branches/new-datamodel/playground/call-next-method.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/call-next-method.lisp Wed Mar 10 11:59:11 2010 @@ -0,0 +1,44 @@ +(defclass Class-1 () + ((value :initarg :value + :accessor value))) + +(defmethod set-value :before ((inst Class-1) value) + (format t ":before -> value is of type ~a~%" (type-of value))) + +(defmethod set-value ((inst Class-1) value) + (format t ": -> value is being set to ~a~%" value) + (setf (slot-value inst 'value) value)) + +(defmethod set-value :after ((inst Class-1) value) + (format t ":after -> value was set to ~a~%" value)) + +(defmethod set-value :around ((inst Class-1) value) + (format t ":around -> ???~%") + (call-next-method inst "123")) ;calls the :before method with the + ;arguments inst and "123" + ;if no arguments are passed the arguments + ;of the :around method are passed + +(defvar *inst* (make-instance 'Class-1)) +(set-value *inst* "val") +;:around -> ??? +;:before -> value is of type (SIMPLE-ARRAY CHARACTER (3)) +;: -> value is being set to 123 +;:after -> value was set to 123 + + +(defclass Class-2 (Class-1) + ()) + +(defmethod set-value ((inst Class-2) value) + (call-next-method) ;calls set-value of Class-1 + (format t "(Class-2): -> value is being set to ~a~%" value) + (setf (slot-value inst 'value) value)) + +(defvar *inst2* (make-instance 'Class-2)) +(set-value *inst2* "val2") +;:around -> ??? +;:before -> value is of type (SIMPLE-ARRAY CHARACTER (3)) +;: -> value is being set to 123 +;(Class-2): -> value is being set to 123 +;:after -> value was set to 123 \ No newline at end of file

1 0

[isidorus-cvs] r222 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 10 Mar '10

10 Mar '10

Author: lgiessmann Date: Wed Mar 10 08:59:47 2010 New Revision: 222 Log: new-datamodel: fixed a bug in "delete-construct"; finalized the unit-tests for "delete-construct" 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 Wed Mar 10 08:59:47 2010 @@ -597,18 +597,7 @@ (defmethod delete-construct :after ((construct elephant:persistent)) - "Removes the passed object from the data base when it is not - referenced by a parent TM construct. - So pointers, characteristics, topics, roles and associations - can be only dropped when there are not owned by a parent." - (if (or (typep construct 'PointerC) - (typep construct 'CharacteristicC) - (typep construct 'TopicC) - (typep construct 'RoleC) - (typep construct 'AssociationC)) - (unless (owned-p construct) - (drop-instance construct)) - (drop-instance construct))) + (drop-instance construct)) (defun filter-slot-value-by-revision (construct slot-symbol @@ -835,7 +824,7 @@ ;;; CharacteristicAssociationC (defmethod delete-construct :before ((construct CharacteristicAssociationC)) - (delete-1-n-association construct 'charactersitic)) + (delete-1-n-association construct 'characteristic)) ;;; OccurrenceAssociationC @@ -867,30 +856,40 @@ ;;; TopicC (defmethod delete-construct :before ((construct TopicC)) - (let ((psis-to-delete - (map 'list #'identifier (slot-p construct 'psis))) - (sls-to-delete - (map 'list #'identifier (slot-p construct 'locators))) - (names-to-delete - (map 'list #'characteristic (slot-p construct 'names))) - (occurrences-to-delete (slot-p construct 'occurrences)) - (roles-to-delete - (map 'list #'parent-construct (slot-p construct 'player-in-roles))) - (typables-to-delete - (map 'list #'typable-construct (slot-p construct 'used-as-type))) + (let ((psi-assocs-to-delete (slot-p construct 'psis)) + (sl-assocs-to-delete (slot-p construct 'locators)) + (name-assocs-to-delete (slot-p construct 'names)) + (occ-assocs-to-delete (slot-p construct 'occurrences)) + (role-assocs-to-delete (slot-p construct 'player-in-roles)) + (type-assocs-to-delete (slot-p construct 'used-as-type)) + (scope-assocs-to-delete (slot-p construct 'used-as-theme)) (reifier-assocs-to-delete (slot-p construct 'reified-construct))) - (dolist (construct-to-delete (append psis-to-delete - sls-to-delete - names-to-delete - occurrences-to-delete - roles-to-delete - typables-to-delete - reifier-assocs-to-delete)) - (delete-construct construct-to-delete))) - (dolist (scope-assoc-to-delete (slot-p construct 'used-as-theme)) - (delete-construct scope-assoc-to-delete)) - (dolist (tm (slot-p construct 'in-topicmaps)) - (remove-association construct 'in-topicmaps tm))) + (let ((all-psis (map 'list #'identifier psi-assocs-to-delete)) + (all-sls (map 'list #'identifier sl-assocs-to-delete)) + (all-names (map 'list #'characteristic name-assocs-to-delete)) + (all-occs (map 'list #'characteristic occ-assocs-to-delete)) + (all-roles (map 'list #'parent-construct role-assocs-to-delete)) + (all-types (map 'list #'typable-construct type-assocs-to-delete))) + (dolist (construct-to-delete (append psi-assocs-to-delete + sl-assocs-to-delete + name-assocs-to-delete + occ-assocs-to-delete + role-assocs-to-delete + type-assocs-to-delete + scope-assocs-to-delete + reifier-assocs-to-delete)) + (delete-construct construct-to-delete)) + (dolist (candidate-to-delete (append all-psis all-sls all-names all-occs)) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (candidate-to-delete all-roles) + (unless (player-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (candidate-to-delete all-types) + (unless (instance-of-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))))) (defmethod owned-p ((construct TopicC)) @@ -1101,7 +1100,7 @@ (:method ((construct TopicC) (name NameC) &key (revision (error "From delete-name(): revision must be set"))) (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) construct) + when (eql (characteristic name-assoc) name) return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1150,7 +1149,7 @@ (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision (error "From delete-occurrence(): revision must be set"))) (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) construct) + when (eql (characteristic occ-assoc) occurrence) return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1301,10 +1300,13 @@ ;;; NameC (defmethod delete-construct :before ((construct NameC)) - (dolist (variant-to-delete - (map 'list #'characteristic - (slot-p construct 'variants))) - (delete-construct variant-to-delete))) + (let ((variant-assocs-to-delete (slot-p construct 'variants))) + (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) + (dolist (variant-assoc-to-delete variant-assocs-to-delete) + (delete-construct variant-assoc-to-delete)) + (dolist (candidate-to-delete all-variants) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete)))))) (defgeneric variants (construct &key revision) @@ -1432,11 +1434,15 @@ ;;; AssociationC (defmethod delete-construct :before ((construct AssociationC)) - (dolist (role-to-delete - (map 'list #'role (slot-p construct 'roles))) - (delete-construct role-to-delete)) - (dolist (tm (slot-p construct 'in-topicmaps)) - (remove-association construct 'in-topicmaps tm))) + (let ((roles-assocs-to-delete (slot-p construct 'roles))) + (let ((all-roles (map 'list #'role roles-assocs-to-delete))) + (dolist (role-assoc-to-delete roles-assocs-to-delete) + (delete-construct role-assoc-to-delete)) + (dolist (candidate-to-delete all-roles) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))))) (defmethod owned-p ((construct AssociationC)) @@ -1499,6 +1505,14 @@ (delete-construct player-assoc-to-delete))) +(defgeneric player-p (construct) + (:documentation "Returns t if a player is set in this role. + t is also returned if the player is markes-as-deleted.") + (:method ((construct RoleC)) + (when (slot-p construct 'player) + t))) + + (defmethod owned-p ((construct RoleC)) (when (slot-p construct 'parent) t)) @@ -1573,7 +1587,7 @@ return player-assoc))) (when (and already-set-player (not (eql already-set-player player-topic))) - (error "From add-player(): ~a can't be palyed by ~a since it is played by ~a" + (error "From add-player(): ~a can't be played by ~a since it is played by ~a" construct player-topic already-set-player)) (cond (already-set-player (let ((player-assoc @@ -1598,7 +1612,7 @@ &key (revision (error "From delete-parent(): revision must be set"))) (let ((assoc-to-delete (loop for player-assoc in (slot-p construct 'player) - when (eql (player-topic player-assoc) player-topic) + when (eql (parent-construct player-assoc) construct) return player-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1607,12 +1621,15 @@ ;;; ReifiableConstructC (defmethod delete-construct :before ((construct ReifiableConstructC)) - (let ((iis-to-delete - (map 'list #'identifier (slot-p construct 'item-identifiers))) - (reifier-tops-to-delete - (map 'list #'reifier-topic (slot-p construct 'reifier)))) - (dolist (construct-to-delete (append iis-to-delete reifier-tops-to-delete)) - (delete-construct construct-to-delete)))) + (let ((ii-assocs-to-delete (slot-p construct 'item-identifiers)) + (reifier-assocs-to-delete (slot-p construct 'reifier))) + (let ((all-iis (map 'list #'identifier ii-assocs-to-delete))) + (dolist (construct-to-delete (append ii-assocs-to-delete + reifier-assocs-to-delete)) + (delete-construct construct-to-delete)) + (dolist (ii all-iis) + (unless (owned-p ii) + (delete-construct ii)))))) (defgeneric item-identifiers (construct &key revision) @@ -1784,6 +1801,15 @@ (dolist (type-assoc-to-delete (slot-p construct 'instance-of)) (delete-construct type-assoc-to-delete))) + +(defgeneric instance-of-p (construct) + (:documentation "Returns t if there is any type set in this object. + t is also returned if the type is marked-as-deleted.") + (:method ((construct TypableC)) + (when (slot-p construct 'instance-of) + t))) + + (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") 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 Wed Mar 10 08:59:47 2010 @@ -39,10 +39,17 @@ :test-TopicMapC :test-delete-ItemIdentifierC :test-delete-PersistentIdC - :test-delete-SubjectLocatorC)) + :test-delete-SubjectLocatorC + :test-delete-ReifiableConstructC + :test-delete-VariantC + :test-delete-NameC + :test-delete-OccurrenceC + :test-delete-TypableC + :test-delete-ScopableC + :test-delete-AssociationC + :test-delete-RoleC)) -;;TODO: test delete-construct ;;TODO: test merge-constructs when merging was caused by an item-dentifier, ;; a psi, a subject-locator, a topic-id ;;TODO: test merge-constructs when merging was caused by reifiers @@ -957,9 +964,15 @@ (add-item-identifier name-2 ii-4 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) 2)) - (delete-construct ii-4) - (is-false (elephant:get-instances-by-class 'ItemIdentifierC)) - (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))))) + (delete-construct occ-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) + (is (= (length (union (list ii-4) (item-identifiers name-2))) 1)) + (delete-construct name-2) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + (is-false (elephant:get-instances-by-class 'ItemIdentifierC))))) + (test test-delete-PersistentIdC () @@ -999,9 +1012,12 @@ (add-psi topic-4 psi-4 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) 2)) - (delete-construct psi-4) - (is-false (elephant:get-instances-by-class 'PersistentIdC)) - (is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC))))) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1)) + (is (= (length (union (list psi-4) (psis topic-4))) 1))))) (test test-delete-SubjectLocatorC () @@ -1041,10 +1057,284 @@ (add-locator topic-4 sl-4 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) 2)) - (delete-construct sl-4) - (is-false (elephant:get-instances-by-class 'SubjectLocatorC)) - (is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))))) - + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (is (= (length (union (list sl-4) (locators topic-4))) 1))))) + + + +(test test-delete-ReifiableConstructC () + "Tests the function delete-construct of the class ReifiableConstructC" + (with-fixture with-empty-db (*db-dir*) + (let ((rc-1 (make-instance 'd::ReifiableConstructC)) + (rc-2 (make-instance 'd::ReifiableConstructC)) + (reifier-1 (make-instance 'TopicC)) + (reifier-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-reifier rc-1 reifier-1) + (add-item-identifier rc-1 ii-1) + (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC)) + 2)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) + 1)) + (delete-reifier rc-1 reifier-1 :revision revision-2) + (delete-item-identifier rc-1 ii-1 :revision revision-2) + (add-reifier rc-2 reifier-1 :revision revision-2) + (add-item-identifier rc-2 ii-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 2)) + (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) + 2)) + (delete-construct rc-1) + (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) + 1)) + (is (= (length (union (list ii-1) (item-identifiers rc-2))) 1)) + (is (eql reifier-1 (reifier rc-2))) + (delete-construct ii-1) + (delete-construct reifier-1) + (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC)) + 1)) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + (is-false (elephant:get-instances-by-class 'd::ReifierAssociationC)) + (delete-construct reifier-2) + (is-false (elephant:get-instances-by-class 'd::ReifierAssociationC))))) + + +(test test-delete-VariantC () + "Tests the function delete-construct of the class VariantC" + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (variant-1 (make-instance 'VariantC)) + (variant-2 (make-instance 'VariantC)) + (variant-3 (make-instance 'VariantC)) + (variant-4 (make-instance 'VariantC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-variant name-1 variant-1) + (add-variant name-1 variant-2) + (add-variant name-1 variant-3) + (delete-variant name-1 variant-1 :revision revision-2) + (delete-variant name-1 variant-2 :revision revision-2) + (add-variant name-2 variant-1 :revision revision-2) + (add-variant name-2 variant-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC)) + 5)) + (delete-construct variant-1) + (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (delete-construct name-1) + (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 2)) + (delete-construct name-2) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 1)) + (is-false (elephant:get-instances-by-class 'd::VariantAssociationC)) + (delete-construct variant-4) + (is-false (elephant:get-instances-by-class 'VariantC))))) + + +(test test-delete-NameC () + "Tests the function delete-construct of the class NameC" + (with-fixture with-empty-db (*db-dir*) + (let ((topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (name-3 (make-instance 'NameC)) + (name-4 (make-instance 'NameC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-name topic-1 name-1) + (add-name topic-1 name-2) + (add-name topic-1 name-3) + (delete-name topic-1 name-1 :revision revision-2) + (delete-name topic-1 name-2 :revision revision-2) + (add-name topic-2 name-1 :revision revision-2) + (add-name topic-2 name-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC)) + 5)) + (delete-construct name-1) + (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 3)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'NameC)) 1)) + (is-false (elephant:get-instances-by-class 'd::NameAssociationC)) + (delete-construct name-4) + (is-false (elephant:get-instances-by-class 'NameC))))) + + +(test test-delete-OccurrenceC () + "Tests the function delete-construct of the class OccurrenceC" + (with-fixture with-empty-db (*db-dir*) + (let ((topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (occurrence-1 (make-instance 'OccurrenceC)) + (occurrence-2 (make-instance 'OccurrenceC)) + (occurrence-3 (make-instance 'OccurrenceC)) + (occurrence-4 (make-instance 'OccurrenceC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-occurrence topic-1 occurrence-1) + (add-occurrence topic-1 occurrence-2) + (add-occurrence topic-1 occurrence-3) + (delete-occurrence topic-1 occurrence-1 :revision revision-2) + (delete-occurrence topic-1 occurrence-2 :revision revision-2) + (add-occurrence topic-2 occurrence-1 :revision revision-2) + (add-occurrence topic-2 occurrence-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class + 'd::OccurrenceAssociationC)) 5)) + (delete-construct occurrence-1) + (is (= (length (elephant:get-instances-by-class + 'd::OccurrenceAssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class + 'd::OccurrenceAssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 1)) + (is-false (elephant:get-instances-by-class 'd::OccurrenceAssociationC)) + (delete-construct occurrence-4) + (is-false (elephant:get-instances-by-class 'OccurrenceC))))) + + +(test test-delete-TypableC () + "Tests the function delete-construct of the class TypableC" + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (type-1 (make-instance 'TopicC)) + (type-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-type name-1 type-1) + (delete-type name-1 type-1 :revision revision-2) + (add-type name-1 type-2 :revision revision-2) + (add-type name-2 type-2) + (is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::NameC)) 2)) + (delete-construct type-2) + (is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd::NameC)) 1)) + (delete-construct name-1) + (is-false (elephant:get-instances-by-class 'd::TypeAssociationC)) + (is-false (elephant:get-instances-by-class 'd::NameC))))) + + +(test test-delete-ScopableC () + "Tests the function delete-construct of the class ScopableC" + (with-fixture with-empty-db (*db-dir*) + (let ((assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (assoc-3 (make-instance 'AssociationC)) + (scope-1 (make-instance 'TopicC)) + (scope-2 (make-instance 'TopicC)) + (scope-3 (make-instance 'TopicC)) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (add-theme assoc-1 scope-1) + (add-theme assoc-1 scope-2) + (add-theme assoc-2 scope-1) + (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (delete-construct scope-1) + (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (delete-construct assoc-1) + (is-false (elephant:get-instances-by-class 'd::ScopeAssociationC)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2)) + (add-theme assoc-2 scope-3) + (add-theme assoc-3 scope-3) + (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC)) + 2)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2)) + (delete-construct assoc-2) + (is (= (length (union (list scope-3) (themes assoc-3))) 1))))) + + +(test test-delete-AssociationC () + "Tests the function delete-construct of the class AssociationC" + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'RoleC)) + (role-2 (make-instance 'RoleC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (assoc-3 (make-instance 'AssociationC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-role assoc-1 role-1) + (delete-role assoc-1 role-1 :revision revision-2) + (add-role assoc-2 role-1 :revision revision-2) + (add-role assoc-2 role-2) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 3)) + (delete-construct role-1) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 1)) + (delete-role assoc-2 role-2 :revision revision-2) + (add-role assoc-3 role-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 2)) + (delete-construct assoc-3) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) + 1))))) + + +(test test-delete-RoleC () + "Tests the function delete-construct of the class RoleC" + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'RoleC)) + (role-2 (make-instance 'RoleC)) + (player-1 (make-instance 'TopicC)) + (player-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-player role-1 player-1) + (delete-player role-1 player-1 :revision revision-2) + (add-player role-1 player-2 :revision revision-2) + (add-player role-2 player-1) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC)) + 3)) + (delete-construct player-1) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC)) + 1)) + (delete-construct role-1) + (is-false (elephant:get-instances-by-class 'RoleC)) + (is-false (elephant:get-instances-by-class 'd::PlayerAssociationC))))) (defun run-datamodel-tests() @@ -1071,4 +1361,12 @@ (it.bese.fiveam:run! 'test-delete-ItemIdentifierC) (it.bese.fiveam:run! 'test-delete-PersistentIdC) (it.bese.fiveam:run! 'test-delete-SubjectLocatorC) + (it.bese.fiveam:run! 'test-delete-ReifiableConstructC) + (it.bese.fiveam:run! 'test-delete-VariantC) + (it.bese.fiveam:run! 'test-delete-NameC) + (it.bese.fiveam:run! 'test-delete-OccurrenceC) + (it.bese.fiveam:run! 'test-delete-TypableC) + (it.bese.fiveam:run! 'test-delete-ScopableC) + (it.bese.fiveam:run! 'test-delete-AssociationC) + (it.bese.fiveam:run! 'test-delete-RoleC) ) \ No newline at end of file

1 0

[isidorus-cvs] r221 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 09 Mar '10

09 Mar '10

Author: lgiessmann Date: Tue Mar 9 12:52:12 2010 New Revision: 221 Log: new-datamodel: fixed a bug in delete-construct (TopicC) and added some unit-tests for delete-construct (PersistentIdC, SubjectLocatorS, ItemIdentifierC) 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 9 12:52:12 2010 @@ -870,7 +870,7 @@ (let ((psis-to-delete (map 'list #'identifier (slot-p construct 'psis))) (sls-to-delete - (map 'list #'identifier (slot-p construct 'psis))) + (map 'list #'identifier (slot-p construct 'locators))) (names-to-delete (map 'list #'characteristic (slot-p construct 'names))) (occurrences-to-delete (slot-p construct 'occurrences)) 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 9 12:52:12 2010 @@ -37,7 +37,9 @@ :test-RoleC :test-player :test-TopicMapC - :test-delete-ItemIdentifierC)) + :test-delete-ItemIdentifierC + :test-delete-PersistentIdC + :test-delete-SubjectLocatorC)) ;;TODO: test delete-construct @@ -924,8 +926,11 @@ (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) (ii-3 (make-instance 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-instance 'ItemIdentifierC :uri "ii-4")) (occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) (revision-1 100) (revision-2 200)) (setf *TM-REVISION* 100) @@ -935,16 +940,110 @@ (add-item-identifier name-1 ii-1 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) 3)) - (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 4)) (delete-construct ii-3) - (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) 3)) (delete-construct ii-1) - ;(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) - ;(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) - ; 2)) - ))) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (delete-construct occ-1) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + (add-item-identifier occ-2 ii-4 :revision revision-1) + (delete-item-identifier occ-2 ii-4 :revision revision-2) + (add-item-identifier name-2 ii-4 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 2)) + (delete-construct ii-4) + (is-false (elephant:get-instances-by-class 'ItemIdentifierC)) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))))) + + +(test test-delete-PersistentIdC () + "Tests the function delete-construct of the class PersistentIdC." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1")) + (psi-2 (make-instance 'PersistentIdC :uri "psi-2")) + (psi-3 (make-instance 'PersistentIdC :uri "psi-3")) + (psi-4 (make-instance 'PersistentIdC :uri "psi-4")) + (topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (topic-3 (make-instance 'TopicC)) + (topic-4 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* 100) + (add-psi topic-1 psi-1 :revision revision-1) + (add-psi topic-1 psi-2 :revision revision-2) + (delete-psi topic-1 psi-1 :revision revision-2) + (add-psi topic-3 psi-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 4)) + (delete-construct psi-3) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 3)) + (delete-construct psi-1) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 1)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1)) + (is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + (add-psi topic-2 psi-4 :revision revision-1) + (delete-psi topic-2 psi-4 :revision revision-2) + (add-psi topic-4 psi-4 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 2)) + (delete-construct psi-4) + (is-false (elephant:get-instances-by-class 'PersistentIdC)) + (is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC))))) + + +(test test-delete-SubjectLocatorC () + "Tests the function delete-construct of the class SubjectLocatorC." + (with-fixture with-empty-db (*db-dir*) + (let ((sl-1 (make-instance 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-instance 'SubjectLocatorC :uri "sl-2")) + (sl-3 (make-instance 'SubjectLocatorC :uri "sl-3")) + (sl-4 (make-instance 'SubjectLocatorC :uri "sl-4")) + (topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (topic-3 (make-instance 'TopicC)) + (topic-4 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* 100) + (add-locator topic-1 sl-1 :revision revision-1) + (add-locator topic-1 sl-2 :revision revision-2) + (delete-locator topic-1 sl-1 :revision revision-2) + (add-locator topic-3 sl-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 4)) + (delete-construct sl-3) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 3)) + (delete-construct sl-1) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 1)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + (add-locator topic-2 sl-4 :revision revision-1) + (delete-locator topic-2 sl-4 :revision revision-2) + (add-locator topic-4 sl-4 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 2)) + (delete-construct sl-4) + (is-false (elephant:get-instances-by-class 'SubjectLocatorC)) + (is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))))) @@ -970,4 +1069,6 @@ (it.bese.fiveam:run! 'test-player) (it.bese.fiveam:run! 'test-TopicMapC) (it.bese.fiveam:run! 'test-delete-ItemIdentifierC) + (it.bese.fiveam:run! 'test-delete-PersistentIdC) + (it.bese.fiveam:run! 'test-delete-SubjectLocatorC) ) \ No newline at end of file

1 0

[isidorus-cvs] r220 - branches/new-datamodel/src/model
by Lukas Giessmann 09 Mar '10

09 Mar '10

Author: lgiessmann Date: Tue Mar 9 12:24:52 2010 New Revision: 220 Log: new-datamodel: finalized "delete-construct" Modified: branches/new-datamodel/src/model/datamodel.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 9 12:24:52 2010 @@ -853,6 +853,18 @@ (delete-1-n-association construct 'parent-construct)) +;;; RoleAssociationC +(defmethod delete-construct :before ((construct RoleAssociationC)) + (delete-1-n-association construct 'role) + (delete-1-n-association construct 'parent-construct)) + + +;;; PlayerAssociationC +(defmethod delete-construct :before ((construct PlayerAssociationC)) + (delete-1-n-association construct 'player-topic) + (delete-1-n-association construct 'parent-construct)) + + ;;; TopicC (defmethod delete-construct :before ((construct TopicC)) (let ((psis-to-delete @@ -862,7 +874,8 @@ (names-to-delete (map 'list #'characteristic (slot-p construct 'names))) (occurrences-to-delete (slot-p construct 'occurrences)) - ;TODO: roles -> associations? + (roles-to-delete + (map 'list #'parent-construct (slot-p construct 'player-in-roles))) (typables-to-delete (map 'list #'typable-construct (slot-p construct 'used-as-type))) (reifier-assocs-to-delete (slot-p construct 'reified-construct))) @@ -870,6 +883,7 @@ sls-to-delete names-to-delete occurrences-to-delete + roles-to-delete typables-to-delete reifier-assocs-to-delete)) (delete-construct construct-to-delete))) @@ -1417,6 +1431,14 @@ ;;; AssociationC +(defmethod delete-construct :before ((construct AssociationC)) + (dolist (role-to-delete + (map 'list #'role (slot-p construct 'roles))) + (delete-construct role-to-delete)) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))) + + (defmethod owned-p ((construct AssociationC)) (when (slot-p construct 'in-topicmaps) t)) @@ -1470,6 +1492,13 @@ ;;; RoleC +(defmethod delete-construct :before ((construct RoleC)) + (dolist (role-assoc-to-delete (slot-p construct 'parent)) + (delete-construct role-assoc-to-delete)) + (dolist (player-assoc-to-delete (slot-p construct 'player)) + (delete-construct player-assoc-to-delete))) + + (defmethod owned-p ((construct RoleC)) (when (slot-p construct 'parent) t))

1 0

[isidorus-cvs] r219 - branches/new-datamodel/src/model
by Lukas Giessmann 09 Mar '10

09 Mar '10

Author: lgiessmann Date: Tue Mar 9 06:11:24 2010 New Revision: 219 Log: new-datamodel: added delete-construct to TopicC, NameC, OccurrenceC, PersistentIdC, ItemIdentifierC, ReifiableConstructC, SubjectLocatorC, VariantC and all their version-associations Modified: branches/new-datamodel/src/model/datamodel.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 9 06:11:24 2010 @@ -763,6 +763,11 @@ ;;; PointerC +(defmethod delete-construct :before ((construct PointerC)) + (dolist (p-assoc (slot-p construct 'identified-construct)) + (delete-construct p-assoc))) + + (defgeneric owned-p (construct) (:documentation "Returns t if the passed construct is referenced by a parent TM construct.")) @@ -785,7 +790,95 @@ (first assocs))))) +;;; PointerAssociationC +(defmethod delete-construct :before ((construct PointerAssociationC)) + (delete-1-n-association construct 'identifier)) + + +;;; ItemIdAssociationC +(defmethod delete-construct :before ((construct ItemIdAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; TopicIdAssociationC +(defmethod delete-construct :before ((construct TopicIdAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; PersistentIdAssociationC +(defmethod delete-construct :before ((construct PersistentIdAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; SubjectLocatorAssociationC +(defmethod delete-construct :before ((construct SubjectLocatorAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; ReifierAssociationC +(defmethod delete-construct :before ((construct ReifierAssociationC)) + (delete-1-n-association construct 'reifiable-construct) + (delete-1-n-association construct 'reifier-topic)) + + +;;; TypeAssociationC +(defmethod delete-construct :before ((construct TypeAssociationC)) + (delete-1-n-association construct 'type-topic) + (delete-1-n-association construct 'typable-construct)) + + +;;; ScopeAssociationC +(defmethod delete-construct :before ((construct ScopeAssociationC)) + (delete-1-n-association construct 'theme-topic) + (delete-1-n-association construct 'scopable-construct)) + + +;;; CharacteristicAssociationC +(defmethod delete-construct :before ((construct CharacteristicAssociationC)) + (delete-1-n-association construct 'charactersitic)) + + +;;; OccurrenceAssociationC +(defmethod delete-construct :before ((construct OccurrenceAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; NameAssociationC +(defmethod delete-construct :before ((construct NameAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; VariantAssociationC +(defmethod delete-construct :before ((construct VariantAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + ;;; TopicC +(defmethod delete-construct :before ((construct TopicC)) + (let ((psis-to-delete + (map 'list #'identifier (slot-p construct 'psis))) + (sls-to-delete + (map 'list #'identifier (slot-p construct 'psis))) + (names-to-delete + (map 'list #'characteristic (slot-p construct 'names))) + (occurrences-to-delete (slot-p construct 'occurrences)) + ;TODO: roles -> associations? + (typables-to-delete + (map 'list #'typable-construct (slot-p construct 'used-as-type))) + (reifier-assocs-to-delete (slot-p construct 'reified-construct))) + (dolist (construct-to-delete (append psis-to-delete + sls-to-delete + names-to-delete + occurrences-to-delete + typables-to-delete + reifier-assocs-to-delete)) + (delete-construct construct-to-delete))) + (dolist (scope-assoc-to-delete (slot-p construct 'used-as-theme)) + (delete-construct scope-assoc-to-delete)) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))) + + (defmethod owned-p ((construct TopicC)) (when (slot-p construct 'in-topicmaps) t)) @@ -1193,6 +1286,13 @@ ;;; NameC +(defmethod delete-construct :before ((construct NameC)) + (dolist (variant-to-delete + (map 'list #'characteristic + (slot-p construct 'variants))) + (delete-construct variant-to-delete))) + + (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") @@ -1243,6 +1343,11 @@ ;;; CharacteristicC +(defmethod delete-construct :before ((construct CharacteristicC)) + (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) + (delete-construct characteristic-assoc-to-delete))) + + (defmethod owned-p ((construct CharacteristicC)) (when (slot-p construct 'parent) t)) @@ -1472,6 +1577,15 @@ ;;; ReifiableConstructC +(defmethod delete-construct :before ((construct ReifiableConstructC)) + (let ((iis-to-delete + (map 'list #'identifier (slot-p construct 'item-identifiers))) + (reifier-tops-to-delete + (map 'list #'reifier-topic (slot-p construct 'reifier)))) + (dolist (construct-to-delete (append iis-to-delete reifier-tops-to-delete)) + (delete-construct construct-to-delete)))) + + (defgeneric item-identifiers (construct &key revision) (:documentation "Returns the ItemIdentifierC-objects that correspond with the passed construct and the passed version.") @@ -1587,6 +1701,11 @@ ;;; ScopableC +(defmethod delete-construct :before ((construct ScopableC)) + (dolist (scope-assoc-to-delete (slot-p construct 'themes)) + (delete-construct scope-assoc-to-delete))) + + (defgeneric themes (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") @@ -1632,6 +1751,10 @@ ;;; TypableC +(defmethod delete-construct :before ((construct TypableC)) + (dolist (type-assoc-to-delete (slot-p construct 'instance-of)) + (delete-construct type-assoc-to-delete))) + (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") @@ -1690,6 +1813,13 @@ ;;; TopicMapC +(defmethod delete-construct :before ((construct TopicMapC)) + (dolist (top (slot-p construct 'topics)) + (remove-association construct 'topics top)) + (dolist (assoc (slot-p construct 'associations)) + (remove-association construct 'associations assoc))) + + (defgeneric topics (construct &key revision) (:documentation "Returns all TopicC-objects that are contained in the tm.") (:method ((construct TopicMapC) &key (revision 0))

1 0

[isidorus-cvs] r218 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 07 Mar '10

07 Mar '10

Author: lgiessmann Date: Sun Mar 7 15:15:38 2010 New Revision: 218 Log: new-datamodel: added the generic "owned-p" and started to optimize the "delete-construct" mechanism. 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 Sun Mar 7 15:15:38 2010 @@ -97,6 +97,7 @@ (in-package :datamodel) +;;TODO: implement delete-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -573,7 +574,7 @@ (when value value)) ;elephant-relations are handled separately, since slot-boundp does not - ;here + ;work here (handler-case (let ((value (slot-value instance slot-symbol))) (when value value)) @@ -596,7 +597,18 @@ (defmethod delete-construct :after ((construct elephant:persistent)) - (drop-instance construct)) + "Removes the passed object from the data base when it is not + referenced by a parent TM construct. + So pointers, characteristics, topics, roles and associations + can be only dropped when there are not owned by a parent." + (if (or (typep construct 'PointerC) + (typep construct 'CharacteristicC) + (typep construct 'TopicC) + (typep construct 'RoleC) + (typep construct 'AssociationC)) + (unless (owned-p construct) + (drop-instance construct)) + (drop-instance construct))) (defun filter-slot-value-by-revision (construct slot-symbol @@ -751,6 +763,16 @@ ;;; PointerC +(defgeneric owned-p (construct) + (:documentation "Returns t if the passed construct is referenced by a parent + TM construct.")) + + +(defmethod owned-p ((construct PointerC)) + (when (slot-p construct 'identified-construct) + t)) + + (defgeneric identified-construct (construct &key revision) (:documentation "Returns the identified-construct -> ReifiableConstructC or TopicC that corresponds with the passed revision.") @@ -764,20 +786,9 @@ ;;; TopicC -(defmethod delete-construct :before ((construct TopicC)) - "Deletes all association objects of the passed construct." - (dolist (assoc (append (slot-p construct 'topic-identifiers) - (slot-p construct 'psis) - (slot-p construct 'locators) - (slot-p construct 'names) - (slot-p construct 'occurrences) - (slot-p construct 'player-in-roles) - (slot-p construct 'used-as-type) - (slot-p construct 'used-as-theme) - (slot-p construct 'reified-construct))) - (delete-construct assoc)) - (dolist (assoc (slot-p construct 'in-topicmaps)) - (remove-association construct 'in-topicmaps assoc))) +(defmethod owned-p ((construct TopicC)) + (when (slot-p construct 'in-topicmaps) + t)) (defgeneric topic-identifiers (construct &key revision) @@ -1232,16 +1243,9 @@ ;;; CharacteristicC -(defmethod delete-construct :before ((construct CharacteristicC)) - "Deletes all association-obejcts." - (dolist (parent-assoc (slot-p construct 'parent)) - (delete-construct parent-assoc))) - - -(defmethod delete-construct :before ((construct NameC)) - "Deletes all association-obejcts." - (dolist (variant-assoc (slot-p construct 'variants)) - (delete-construct variant-assoc))) +(defmethod owned-p ((construct CharacteristicC)) + (when (slot-p construct 'parent) + t)) (defgeneric parent (construct &key revision) @@ -1307,112 +1311,10 @@ construct))) -;;; PlayerAssociationC -(defmethod delete-construct :before ((construct PlayerAssociationC)) - "Deletes all elephant-associations." - (delete-1-n-association construct 'player-topic) - (delete-1-n-association construct 'parent-construct)) - - -;;; RoleAssociationC -(defmethod delete-construct :before ((construct RoleAssociationC)) - "Deletes all elephant-associations and the entire role if it is not - associated with another AssociationC object." - (let ((role (role construct))) - (delete-1-n-association construct 'role) - (when (not (slot-p role 'parent)) - (delete-construct role)) - (delete-1-n-association construct 'parent-construct))) - - -;;; VariantAssociationC -(defmethod delete-construct :before ((construct VariantAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; NameAssociationC -(defmethod delete-construct :before ((construct NameAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; OccurrenceAssociationC -(defmethod delete-construct :before ((construct OccurrenceAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; CharacteristicAssociationC -(defmethod delete-construct :before ((construct CharacteristicAssociationC)) - "Deletes all elephant-associations." - (let ((characteristic (characteristic construct))) - (delete-1-n-association construct 'characteristic) - (when (and characteristic - (not (slot-p characteristic 'parent))) - (delete-construct characteristic)))) - - -;;; TypeAssociationC -(defmethod delete-construct :before ((construct TypeAssociationC)) - "Deletes all elephant-associations of the given construct." - (delete-1-n-association construct 'type-topic) - (delete-1-n-association construct 'typable-construct)) - - -;;; ScopeAssociationC -(defmethod delete-construct :before ((construct ScopeAssociationC)) - "Deletes all elephant-associations of this construct." - (delete-1-n-association construct 'theme-topic) - (delete-1-n-association construct 'scopable-topic)) - - -;;; ReifierAssociationC -(defmethod delete-construct :before ((construct ReifierAssociationC)) - "Deletes the association-construct and the reifier-topic when it - is not used as a reifier of another construct." - (delete-1-n-association construct 'reifiable-construct) - (let ((reifier-top (slot-p construct 'reifier-topic))) - (delete-1-n-association construct 'reifier-topic) - (when (= (length (slot-p reifier-top 'reified-construct)) 0) - (delete-construct reifier-top)))) - - -;;; SubjectLocatorAssociationC -(defmethod delete-construct :before ((construct SubjectLocatorAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; PersistentIdAssociationC -(defmethod delete-construct :before ((construct PersistentIdAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; TopicIdAssociationC -(defmethod delete-construct :before ((construct TopicIdAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; ItemIdAssociationC -(defmethod delete-construct :before ((construct ItemIdAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; PointerAssociationC -(defmethod delete-construct :before ((construct PointerAssociationC)) - "Deletes the association-construct and the pointer if it is not used - as an idengtiffier of any other object." - (let ((id (slot-p construct 'identifier))) - (delete-1-n-association construct 'identifier) - (when (= (length (slot-p id 'identified-construct)) 0) - (delete-construct id)))) - - ;;; AssociationC -(defmethod delete-construct :before ((construct AssociationC)) - "Removes all elephant-associations and deleted all roles that are not - associated by another associations." - (dolist (assoc (slot-p construct 'roles)) - (delete-construct assoc)) - (dolist (tm (in-topicmaps construct)) - (remove-association construct 'in-topicmaps tm))) +(defmethod owned-p ((construct AssociationC)) + (when (slot-p construct 'in-topicmaps) + t)) (defgeneric roles (construct &key revision) @@ -1463,12 +1365,9 @@ ;;; RoleC -(defmethod delete-construct :before ((construct RoleC)) - "Deletes all association-objects." - (dolist (assoc (slot-p construct 'parent)) - (delete-construct assoc)) - (dolist (assoc (slot-p construct 'player)) - (delete-construct assoc))) +(defmethod owned-p ((construct RoleC)) + (when (slot-p construct 'parent) + t)) (defmethod parent ((construct RoleC) &key (revision 0)) @@ -1592,16 +1491,6 @@ (reifier-topic (first assocs)))))) -(defmethod delete-construct :before ((construct ReifiableConstructC)) - "Deletes the passed construct its item-identifiers and its - reifiers. An item-identifier and a reifeir is only deleted - when these constructs are not referenced by other parent-objects." - (dolist (item-identifier (slot-p construct 'item-identifiers)) - (delete-construct item-identifier)) - (dolist (reifier-top (slot-p construct 'reifier)) - (delete-construct reifier-top))) - - (defgeneric add-item-identifier (construct item-identifier &key revision) (:documentation "Adds the passed item-identifier to the passed construct. If the item-identifier is already related with the passed @@ -1698,12 +1587,6 @@ ;;; ScopableC -(defmethod delete-construct :before ((construct ScopableC)) - "Deletes all ScopeAssociationCs that are associated with the given object." - (dolist (theme (slot-p construct 'themes)) - (delete-construct theme))) - - (defgeneric themes (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") @@ -1749,12 +1632,6 @@ ;;; TypableC -(defmethod delete-construct :before ((construct TypableC)) - "Deletes all TypeAssociationCs that are associated with this object." - (dolist (type (slot-p construct 'instance-of)) - (delete-construct type))) - - (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") 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 Sun Mar 7 15:15:38 2010 @@ -36,7 +36,8 @@ :test-ScopableC :test-RoleC :test-player - :test-TopicMapC)) + :test-TopicMapC + :test-delete-ItemIdentifierC)) ;;TODO: test delete-construct @@ -915,6 +916,35 @@ (in-topicmaps assoc-1))) 2)) (is-false (associations tm-2 :revision revision-0-5)) (is-false (in-topicmaps assoc-1 :revision revision-0-5))))) + + +(test test-delete-ItemIdentifierC () + "Tests the function delete-construct of the class ItemIdentifierC." + (with-fixture with-empty-db (*db-dir*) + (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-instance 'ItemIdentifierC :uri "ii-3")) + (occ-1 (make-instance 'OccurrenceC)) + (name-1 (make-instance 'NameC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* 100) + (add-item-identifier occ-1 ii-1 :revision revision-1) + (add-item-identifier occ-1 ii-2 :revision revision-2) + (delete-item-identifier occ-1 ii-1 :revision revision-2) + (add-item-identifier name-1 ii-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) + (delete-construct ii-3) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 3)) + (delete-construct ii-1) + ;(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) + ;(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + ; 2)) + ))) @@ -938,4 +968,6 @@ (it.bese.fiveam:run! 'test-ScopableC) (it.bese.fiveam:run! 'test-RoleC) (it.bese.fiveam:run! 'test-player) - (it.bese.fiveam:run! 'test-TopicMapC)) \ No newline at end of file + (it.bese.fiveam:run! 'test-TopicMapC) + (it.bese.fiveam:run! 'test-delete-ItemIdentifierC) + ) \ No newline at end of file

1 0