isidorus-cvs October 2010

isidorus-cvs@common-lisp.net

1 participants
16 discussions

[isidorus-cvs] r333 - in trunk/src: model rest_interface
by Lukas Giessmann 25 Oct '10

25 Oct '10

Author: lgiessmann Date: Mon Oct 25 12:34:30 2010 New Revision: 333 Log: fixed ticket #83 -> instead of throwing exceptions when errors occur in the tmcl-information-generation, there is returned an tmcl-info-object with reseted fields; fixed a bug in json-fragment-generation when its type was marked-as-deleted Modified: trunk/src/model/datamodel.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Mon Oct 25 12:34:30 2010 @@ -682,12 +682,13 @@ (let ((psi-inst (elephant:get-instance-by-value 'PersistentIdC 'uri topic-psi))) - (let ((latest-va - (get-most-recent-versioned-assoc - psi-inst 'identified-construct))) - (when (and latest-va (versions latest-va)) - (identified-construct - psi-inst :revision (start-revision (first (versions latest-va)))))))) + (when psi-inst + (let ((latest-va + (get-most-recent-versioned-assoc + psi-inst 'identified-construct))) + (when (and latest-va (versions latest-va)) + (identified-construct + psi-inst :revision (start-revision (first (versions latest-va))))))))) (defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) @@ -2156,10 +2157,12 @@ #'null (map 'list #'(lambda(x) - (when (loop for psi in (psis (instance-of x :revision revision) - :revision revision) - when (string= (uri psi) constants:*instance-psi*) - return t) + (when (and (parent x :revision revision) + (instance-of x :revision revision) + (loop for psi in (psis (instance-of x :revision revision) + :revision revision) + when (string= (uri psi) constants:*instance-psi*) + return t)) (loop for role in (roles (parent x :revision revision) :revision revision) when (not (eq role x)) 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 Mon Oct 25 12:34:30 2010 @@ -252,12 +252,9 @@ hunchentoot:+http-not-found+) (setf (hunchentoot:content-type*) "text") (format nil "Topic \"~a\" not found." psis))))) - (condition (err) - (progn - (setf (hunchentoot:return-code*) - hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) + (condition () + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + "{\"topicConstraints\":{\"exclusiveInstances\":null,\"subjectIdentifierConstraints\":null,\"subjectLocatorConstraints\":null,\"topicNameConstraints\":null,\"topicOccurrenceConstraints\":null,\"abstractConstraint\":false},\"associationsConstraints\":null}")))) (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))

1 0

[isidorus-cvs] r332 - in trunk/src: . json rest_interface unit_tests
by Lukas Giessmann 24 Oct '10

24 Oct '10

Author: lgiessmann Date: Sun Oct 24 12:43:48 2010 New Revision: 332 Log: fixed tifcket #81 -> fixed some bugs with the mark-as-deleted-handler of the UI when some topictypes are deleted and tmcl information is generated; adaption of the datamodel-unit-tests of TopicMapC with the equality of TopicMapC; fixed ticket #78 -> added a json unit-test that tests lage xml-contents in topic-occurrences that are serialized and deserialized to and from json; fixed ticket #80 -> added a RESTful handler that returns the latest used revision of the storage Added: trunk/src/unit_tests/poems_light.xtm.txt - copied unchanged from r328, /trunk/src/unit_tests/poems_light.xtm Modified: trunk/src/isidorus.asd trunk/src/json/json_tmcl.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/datamodel_test.lisp trunk/src/unit_tests/json_test.lisp trunk/src/unit_tests/unittests-constants.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sun Oct 24 12:43:48 2010 @@ -113,6 +113,7 @@ (:static-file "poems.rdf") (:static-file "poems_light.rdf") (:static-file "poems_light.xtm") + (:static-file "poems_light.xtm.txt") (:static-file "poems_light_tm_ii.xtm") (:static-file "poems_light_tm_ii_merge.xtm") (:static-file "poems_light_tm_reification_xtm1.0.xtm") Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Sun Oct 24 12:43:48 2010 @@ -111,9 +111,11 @@ (concatenate 'string "\"rolePlayerConstraints\":" value))) (otherrole-constraints (let ((value - (get-otherrole-constraints - (getf constraint-topics :otherrole-constraints) - :revision revision))) + (handler-case + (get-otherrole-constraints + (getf constraint-topics :otherrole-constraints) + :revision revision) + (condition () "null")))) (concatenate 'string "\"otherRoleConstraints\":" value)))) (let ((json-string (concatenate 'string "{" associationtype "," associationrole-constraints @@ -154,7 +156,8 @@ :revision revision))) (loop for role in (player-in-roles constraint-topic :revision revision) - when (and (eq constraint-role + when (and (parent role :revision revision) + (eq constraint-role (instance-of role :revision revision)) (eq applies-to (instance-of (parent role :revision revision) @@ -697,6 +700,7 @@ when (and (eq constraint-role (instance-of role :revision revision)) + (parent role :revision revision) (eq applies-to (instance-of (parent role :revision revision) :revision revision))) @@ -1655,6 +1659,7 @@ (instance-of role :revision revision)) (eq othertopictype-role (instance-of role :revision revision))) + (parent role :revision revision) (eq applies-to (instance-of (parent role :revision revision) :revision revision))) @@ -1679,6 +1684,7 @@ :revision revision) when (and (eq constraint-role (instance-of c-role :revision revision)) + (parent c-role :revision revision) (eq applies-to (instance-of (parent c-role :revision revision) 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 Sun Oct 24 12:43:48 2010 @@ -53,6 +53,8 @@ (defparameter *ajax-javascript-url-prefix* "/javascripts") ;the url suffix that calls the mark-as-deleted handler (defparameter *mark-as-deleted-url* "/mark-as-deleted") +;the get url to request the latest revision of the storage +(defparameter *latest-revision-url* "/json/latest-revision/?$") (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*) @@ -72,7 +74,8 @@ (ajax-user-interface-css-directory-path *ajax-user-interface-css-directory-path*) (ajax-javascripts-directory-path *ajax-javascript-directory-path*) (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) - (mark-as-deleted-url *mark-as-deleted-url*)) + (mark-as-deleted-url *mark-as-deleted-url*) + (latest-revision-url *latest-revision-url*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -148,6 +151,9 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher latest-revision-url #'return-latest-revision) hunchentoot:*dispatch-table*)) ;; ============================================================================= @@ -431,6 +437,25 @@ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) +(defun return-latest-revision () + "Returns an integer that represents the latest revision that + is used in the storage." + (handler-case + (if (eql (hunchentoot:request-method*) :GET) + (let ((sorted-revisions + (with-reader-lock (sort (d:get-all-revisions) #'>)))) + (when sorted-revisions + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (format nil "~a" (first sorted-revisions)))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)) + (condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err))))) + + + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; ============================================================================= Modified: trunk/src/unit_tests/datamodel_test.lisp ============================================================================== --- trunk/src/unit_tests/datamodel_test.lisp (original) +++ trunk/src/unit_tests/datamodel_test.lisp Sun Oct 24 12:43:48 2010 @@ -1950,7 +1950,9 @@ (is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2))) (is-false (d::equivalent-construct tm-1 :reifier reifier-2)) (is-false (d::strictly-equivalent-constructs tm-1 tm-1)) - (is-false (d::strictly-equivalent-constructs tm-1 tm-2)))))) + ;in our definition TopicMapC-constructs are always equal, since + ;item-identifiers and reifiers are not used for TMDM equlity + (is-true (d::strictly-equivalent-constructs tm-1 tm-2)))))) (test test-class-p () Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Sun Oct 24 12:43:48 2010 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :json-test - (:use + (:use :common-lisp :xml-importer :json-exporter @@ -46,7 +46,8 @@ :test-delete-from-json-occurrence :test-delete-from-json-variant :test-delete-from-json-association - :test-delete-from-json-role)) + :test-delete-from-json-role + :test-occurrence-xml-content)) (in-package :json-test) @@ -58,6 +59,13 @@ (in-suite json-tests) +(defun read-file (strm) + "Reads a file from the beginning to the end." + (if (= (cl-user::stream-file-position strm) (file-length strm)) + "" + (format nil "~a~%~a" (read-line strm) (read-file strm)))) + + (defvar *t100-1* "{\"topic\":{\"id\":\"t970\",\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/standard/Common+Lisp\"],\"instanceOfs\":[[\"http://psi.egovpt.org/types/standard\"]],\"names\":[{\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100_n1\",\"http://www.egovpt.org/itemIdentifiers#t100_n1a\"],\"type\":null,\"scopes\":null,\"value\":\"Common Lisp\",\"variants\":[{\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100_n_v1\"],\"scopes\":[[\"http://www.topicmaps.org/xtm/1.0/core.xtm#sort\"],[\"http://psi.egovpt.org/types/long-name\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",\"value\":\"Common-Lisp\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100_o1\"],\"type\":[\"http://psi.egovpt.org/types/links\"],\"scopes\":null,\"resourceRef\":\"http://www.common-lisp.net/\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"t220\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t3\",\"http://www.egovpt.org/itemIdentifiers#t3\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/standard\"]},{\"id\":\"t68\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://www.topicmaps.org/xtm/1.0/core.xtm#sort\"]},{\"id\":\"t284\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/long-name\"]},{\"id\":\"t324\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t55\",\"http://psi.egovpt.org/itemIdentifiers#t55_1\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/links\"]}],\"associations\":null,\"tmIds\":[\"http://www.isidor.us/unittests/testtm\"]}") (defvar *t100-2* "{\"topic\":{\"id\":\"t945\",\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100\",\"http://www.egovpt.org/itemIdentifiers#t100_new\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/standard/Common+Lisp\"],\"instanceOfs\":[[\"http://psi.egovpt.org/types/standard\"]],\"names\":[{\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"Common Lisp\",\"variants\":[{\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100_n_v1\"],\"scopes\":[[\"http://www.topicmaps.org/xtm/1.0/core.xtm#sort\"],[\"http://psi.egovpt.org/types/long-name\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",\"value\":\"Common-Lisp\"}},{\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100_n_v2\"],\"scopes\":[[\"http://www.topicmaps.org/xtm/1.0/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",\"value\":\"CL\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http://www.egovpt.org/itemIdentifiers#t100_o2\"],\"type\":[\"http://psi.egovpt.org/types/links\"],\"scopes\":null,\"resourceRef\":\"http://www.cliki.net/\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"t220\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t3\",\"http://www.egovpt.org/itemIdentifiers#t3\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/standard\"]},{\"id\":\"t68\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://www.topicmaps.org/xtm/1.0/core.xtm#sort\"]},{\"id\":\"t284\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/long-name\"]},{\"id\":\"t74\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://www.topicmaps.org/xtm/1.0/core.xtm#display\"]},{\"id\":\"t324\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/links\"]}],\"associations\":null,\"tmIds\":[\"http://www.isidor.us/unittests/testtm\"]}") @@ -2141,7 +2149,42 @@ (is-false (mark-as-deleted-from-json j-req-3)) (is (= (length (roles assoc-1)) 2)) (is (= (length (roles assoc-2)) 2))))))))) - + + +(test test-occurrence-xml-content + "Tests the handling of long xml-contents in occurrences when serialized + and deserialised to and from json." + (with-fixture with-empty-db ("data_base") + (elephant:open-store (xml-importer:get-store-spec "data_base")) + (let ((xml-data + (with-open-file + (stream unittests-constants::*poems_light.xtm.txt* + :direction :input) + (read-file stream))) + (rev-1 100)) + (let* ((occ-type (make-construct 'd:TopicC + :start-revision rev-1 + :psis (list (make-construct 'd:PersistentIdC + :start-revision rev-1 + :uri "occ-type")))) + (top (make-construct 'd:TopicC + :start-revision rev-1 + :psis (list (make-construct 'd:PersistentIdC + :uri "test-topic" + :start-revision rev-1)) + :occurrences + (list (make-construct 'd:OccurrenceC + :start-revision rev-1 + :instance-of occ-type + :charvalue xml-data))))) + (is-true (occurrences top)) + (is (string= (d:charvalue (first (occurrences top))) xml-data)) + (let ((json-string + (to-json-string (first (occurrences top))))) + (is (string= (cdr (third (fifth (json:decode-json-from-string + json-string)))) + xml-data))))))) + @@ -2173,4 +2216,5 @@ (it.bese.fiveam:run! 'test-delete-from-json-occurrence) (it.bese.fiveam:run! 'test-delete-from-json-variant) (it.bese.fiveam:run! 'test-delete-from-json-association) - (it.bese.fiveam:run! 'test-delete-from-json-role)) \ No newline at end of file + (it.bese.fiveam:run! 'test-delete-from-json-role) + (it.bese.fiveam:run! 'test-occurrence-xml-content)) \ No newline at end of file Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Sun Oct 24 12:43:48 2010 @@ -31,6 +31,7 @@ :*atom-conf.lisp* :*poems_light.rdf* :*poems_light.xtm* + :*poems_light.xtm.txt* :*full_mapping.rdf* :*reification_xtm1.0.xtm* :*reification_xtm2.0.xtm* @@ -107,6 +108,10 @@ (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light.xtm"))) +(defparameter *poems_light.xtm.txt* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "poems_light.xtm.txt"))) + (defparameter *full_mapping.rdf* (asdf:component-pathname (asdf:find-component *unit-tests-component* "full_mapping.rdf")))

1 0

[isidorus-cvs] r331 - in trunk/src: json rest_interface
by Lukas Giessmann 21 Oct '10

21 Oct '10

Author: lgiessmann Date: Thu Oct 21 05:36:58 2010 New Revision: 331 Log: fixed ticket #73 -> implented caching for topictypes and topic instances Modified: trunk/src/json/json_delete_interface.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/json/json_delete_interface.lisp ============================================================================== --- trunk/src/json/json_delete_interface.lisp (original) +++ trunk/src/json/json_delete_interface.lisp Thu Oct 21 05:36:58 2010 @@ -83,7 +83,7 @@ return role))) (when role-to-delete (d:delete-role parent-assoc role-to-delete :revision revision) - t))))) + role-to-delete))))) (defun delete-association-from-json (json-decoded-list &key @@ -94,7 +94,7 @@ (let ((assoc (find-association json-decoded-list :revision revision))) (when assoc (d:mark-as-deleted assoc :revision revision :source-locator nil) - t))) + assoc))) (defun make-role-plist (json-decoded-list &key (revision *TM-REVISION*)) @@ -217,7 +217,7 @@ scopes (d:themes var :revision revision)))) return var))) (when var-to-delete (delete-variant parent-name var-to-delete :revision revision) - t))))) + var-to-delete))))) (defun delete-occurrence-from-json (json-decoded-list parent-top @@ -258,7 +258,7 @@ return occ))) (when occ-to-delete (delete-occurrence parent-top occ-to-delete :revision revision) - t))))) + occ-to-delete))))) (defun delete-name-from-json (json-decoded-list parent-top @@ -287,7 +287,7 @@ return name))) (when name-to-delete (delete-name parent-top name-to-delete :revision revision) - t))))) + name-to-delete))))) (defun delete-identifier-from-json (uri class delete-function @@ -302,7 +302,7 @@ (apply delete-function (list (d:identified-construct id :revision revision) id :revision revision)) - t) + id) nil))) @@ -314,7 +314,7 @@ json-decoded-list :revision revision))) (when top-to-delete (mark-as-deleted top-to-delete :source-locator nil :revision revision) - t))) + top-to-delete))) (defun get-ids-from-json (json-decoded-list) Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Thu Oct 21 05:36:58 2010 @@ -81,11 +81,6 @@ (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 Thu Oct 21 05:36:58 2010 @@ -9,6 +9,11 @@ (in-package :rest-interface) +;caching tables +(defparameter *type-table* nil) +(defparameter *instance-table* nil) + + ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> (defparameter *json-get-prefix* "/json/get/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi> @@ -71,6 +76,11 @@ "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" + ;initializes cache and fragments + (init-cache) + (format t "~%") + (init-fragments) + ;; registers the http-code 500 for an internal server error to the standard ;; return codes. so there won't be attached a hunchentoot default message, ;; this is necessary to be able to send error messages in an individual way/syntax @@ -149,7 +159,10 @@ (declare (ignorable param)) (handler-case (let ((topic-types (with-reader-lock - (json-tmcl::return-all-tmcl-types :revision 0)))) + (map 'list #'(lambda (oid) + (elephant::controller-recreate-instance + elephant::*store-controller* oid)) + *type-table*)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -168,7 +181,10 @@ (declare (ignorable param)) (handler-case (let ((topic-instances (with-reader-lock - (json-tmcl::return-all-tmcl-instances :revision 0)))) + (map 'list #'(lambda (oid) + (elephant::controller-recreate-instance + elephant::*store-controller* oid)) + *instance-table*)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -314,8 +330,11 @@ (eq http-method :POST)) (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) - (handler-case (with-writer-lock - (json-importer:json-to-elem json-data)) + (handler-case + (with-writer-lock + (let ((frag (json-importer:json-to-elem json-data))) + (when frag + (push-to-cache (d:topic frag))))) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) @@ -396,7 +415,11 @@ (let ((result (json-delete-interface:mark-as-deleted-from-json json-data :revision (d:get-revision)))) (if result - (format nil "") ;operation succeeded + (progn + (when (typep result 'd:TopicC) + (delete (elephant::oid result) *type-table*) + (delete (elephant::oid result) *instance-table*)) + (format nil "")) ;operation succeeded (progn (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) (format nil "object not found"))))) @@ -456,3 +479,48 @@ (incf idx))) (unless (< idx (length str)) (return ret-str))))))) + + +(defun init-cache() + "Initializes the type and instance cache-tables with all valid types/instances" + (with-writer-lock + (setf *type-table* nil) + (setf *instance-table* nil) + (let ((topictype (get-item-by-psi json-tmcl-constants::*topictype-psi* + :revision 0)) + (topictype-constraint (json-tmcl::is-type-constrained :revision 0))) + (format t "~%initialize cache: ") + (map 'list #'(lambda(top) + (format t ".") + (push-to-cache top topictype topictype-constraint)) + (elephant:get-instances-by-class 'TopicC))))) + + +(defun push-to-cache (topic-instance &optional + (topictype + (get-item-by-psi + json-tmcl::*topictype-psi* :revision 0)) + (topictype-constraint + (json-tmcl::is-type-constrained :revision 0))) + "Pushes the given topic-instance into the correspondng cache-tables" + (when (not (json-tmcl::abstract-p topic-instance :revision 0)) + (handler-case (progn + (json-tmcl::topictype-p + topic-instance topictype topictype-constraint nil 0) + (push (elephant::oid topic-instance) *type-table*)) + (condition () nil))) + (handler-case (progn + (json-tmcl::valid-instance-p topic-instance nil nil 0) + (push (elephant::oid topic-instance) *instance-table*)) + (condition () nil))) + + +(defun init-fragments () + "Creates fragments of all topics that have a PSI." + (format t "create fragments: ") + (map 'list #'(lambda(top) + (let ((psis-of-top (psis top))) + (when psis-of-top + (format t ".") + (create-latest-fragment-of-topic (uri (first psis-of-top)))))) + (elephant:get-instances-by-class 'd:TopicC))) \ No newline at end of file

1 0

[isidorus-cvs] r330 - in trunk/src: . unit_tests xml/xtm
by Lukas Giessmann 16 Oct '10

16 Oct '10

Author: lgiessmann Date: Sat Oct 16 12:15:50 2010 New Revision: 330 Log: fixed ticket #64 --> reifier of the TopicMap-element for xtm 1.0; added a corresponding unit-test; this problem was solved for the xtm 2.0 importer in revision 329 Added: trunk/src/unit_tests/poems_light_tm_reification_xtm1.0.xtm Modified: trunk/src/isidorus.asd trunk/src/unit_tests/importer_test.lisp trunk/src/unit_tests/poems_light_tm_ii.xtm trunk/src/unit_tests/poems_light_tm_ii_merge.xtm trunk/src/unit_tests/unittests-constants.lisp trunk/src/xml/xtm/exporter.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sat Oct 16 12:15:50 2010 @@ -115,6 +115,7 @@ (:static-file "poems_light.xtm") (:static-file "poems_light_tm_ii.xtm") (:static-file "poems_light_tm_ii_merge.xtm") + (:static-file "poems_light_tm_reification_xtm1.0.xtm") (:static-file "full_mapping.rdf") (:static-file "reification_xtm1.0.xtm") (:static-file "reification_xtm2.0.xtm") Modified: trunk/src/unit_tests/importer_test.lisp ============================================================================== --- trunk/src/unit_tests/importer_test.lisp (original) +++ trunk/src/unit_tests/importer_test.lisp Sat Oct 16 12:15:50 2010 @@ -40,7 +40,8 @@ :test-topicmaps :test-variants :test-variants-xtm1.0 - :test-merge-topicmaps)) + :test-merge-topicmaps + :test-merge-topicmaps-xtm1.0)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) (in-package :importer-test) @@ -710,6 +711,9 @@ "http://some.where/poems_light_tm_ii_1" "http://some.where/poems_light_tm_ii_2") :test #'string=)) + (is (eql (reifier tm-1) + (d:get-item-by-item-identifier + "http://some.where/poems/topicMap-reifier"))) (is (= (length (d:topics tm-1)) 9)) (is (= (length (d:associations tm-1)) (+ 1 3))) (is (= (length (d:in-topicmaps (d:get-item-by-id "schiller"))) 1)) @@ -727,6 +731,25 @@ (is-false schiller-2))))))) +(test test-merge-topicmaps-xtm1.0 + (let ((dir "data_base") + (tm-id-1 "tm-id-1")) + (with-fixture with-empty-db (dir) + (xml-importer:setup-repository *poems_light_tm_reification_xtm1.0.xtm* + dir :tm-id tm-id-1 :xtm-format '1.0) + (elephant:open-store (xml-importer:get-store-spec dir)) + (with-revision 0 + (let ((tm-1 + (d:identified-construct + (first (elephant:get-instances-by-value + 'd:ItemIdentifierC 'd:uri tm-id-1))))) + (is-true tm-1) + (is (= (length (topics tm-1)) 8)) + (is (= (length (associations tm-1)) (+ 1 2))) + (is (eql (reifier tm-1) + (get-item-by-psi "#tm-reifier")))))))) + + (defun run-importer-tests () (run! 'importer-test)) Modified: trunk/src/unit_tests/poems_light_tm_ii.xtm ============================================================================== --- trunk/src/unit_tests/poems_light_tm_ii.xtm (original) +++ trunk/src/unit_tests/poems_light_tm_ii.xtm Sat Oct 16 12:15:50 2010 @@ -13,9 +13,6 @@ <tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/" reifier="http://some.where/poems/topicMap-reifier"> -  <tm:itemIdentity href="http://some.where/poems_light_tm_ii_1"/> <tm:itemIdentity href="http://some.where/poems_light_tm_ii_2"/> Modified: trunk/src/unit_tests/poems_light_tm_ii_merge.xtm ============================================================================== --- trunk/src/unit_tests/poems_light_tm_ii_merge.xtm (original) +++ trunk/src/unit_tests/poems_light_tm_ii_merge.xtm Sat Oct 16 12:15:50 2010 @@ -12,9 +12,6 @@  <tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/"> -  <tm:itemIdentity href="http://some.where/poems_light_tm_ii_1"/> <tm:topic id="author"> Added: trunk/src/unit_tests/poems_light_tm_reification_xtm1.0.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/poems_light_tm_reification_xtm1.0.xtm Sat Oct 16 12:15:50 2010 @@ -0,0 +1,89 @@ +<?xml version="1.0" encoding="UTF-8"?> + + + + + + + + + + + + +<tm:topicMap xmlns:tm="http://www.topicmaps.org/xtm/1.0/" + xmlns:xlink="http://www.w3.org/1999/xlink" + id="tm-reifier"> + + <tm:topic id="tm-reifier-topic"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="#tm-reifier"/> + </tm:subjectIdentity> + </tm:topic> + + <tm:topic id="author"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="http://some.where/types/Author"/> + </tm:subjectIdentity> + </tm:topic> + + <tm:topic id="poem"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="http://some.where/types/Poem"/> + </tm:subjectIdentity> + </tm:topic> + + <tm:topic id="writer"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="http://some.where/roletype/writer"/> + </tm:subjectIdentity> + </tm:topic> + + <tm:topic id="written"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="http://some.where/roletype/written"/> + </tm:subjectIdentity> + </tm:topic> + + <tm:topic id="wrote"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="http://some.where/relationship/wrote"/> + </tm:subjectIdentity> + </tm:topic> + + <tm:topic id="goethe"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="http://some.where/author/Goethe"/> + </tm:subjectIdentity> + <tm:instanceOf> + <tm:topicRef xlink:href="#author"/> + </tm:instanceOf> + </tm:topic> + + <tm:topic id="zauberlehrling"> + <tm:subjectIdentity> + <tm:subjectIndicatorRef xlink:href="http://some.where/poem/Der_Zauberlehrling"/> + </tm:subjectIdentity> + <tm:instanceOf> + <tm:topicRef xlink:href="#poem"/> + </tm:instanceOf> + </tm:topic> + + <tm:association> + <tm:instanceOf> + <tm:topicRef xlink:href="#wrote"/> + </tm:instanceOf> + <tm:member> + <tm:roleSpec> + <tm:topicRef xlink:href="#writer"/> + </tm:roleSpec> + <tm:topicRef xlink:href="#goethe"/> + </tm:member> + <tm:member> + <tm:roleSpec> + <tm:topicRef xlink:href="#written"/> + </tm:roleSpec> + <tm:topicRef xlink:href="#zauberlehrling"/> + </tm:member> + </tm:association> +</tm:topicMap> Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Sat Oct 16 12:15:50 2010 @@ -36,7 +36,8 @@ :*reification_xtm2.0.xtm* :*reification.rdf* :*poems_light_tm_ii.xtm* - :*poems_light_tm_ii_merge.xtm*)) + :*poems_light_tm_ii_merge.xtm* + :*poems_light_tm_reification_xtm1.0.xtm*)) (in-package :unittests-constants) @@ -122,12 +123,14 @@ (asdf:component-pathname (asdf:find-component *unit-tests-component* "reification.rdf"))) - (defparameter *poems_light_tm_ii.xtm* (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light_tm_ii.xtm"))) - (defparameter *poems_light_tm_ii_merge.xtm* (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light_tm_ii_merge.xtm"))) + +(defparameter *poems_light_tm_reification_xtm1.0.xtm* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "poems_light_tm_reification_xtm1.0.xtm"))) Modified: trunk/src/xml/xtm/exporter.lisp ============================================================================== --- trunk/src/xml/xtm/exporter.lisp (original) +++ trunk/src/xml/xtm/exporter.lisp Sat Oct 16 12:15:50 2010 @@ -53,12 +53,14 @@ ,@body))) -(defmacro with-xtm1.0 (&body body) +(defmacro with-xtm1.0 ((tm revision) &body body) "helper macro to build the Topic Map element" `(cxml:with-namespace ("t" *xtm1.0-ns*) (cxml:with-namespace ("xlink" *xtm1.0-xlink*) (cxml:with-element "t:topicMap" :empty + (when ,tm + (to-reifier-elem-xtm1.0 ,tm ,revision)) ,@body)))) @@ -98,7 +100,7 @@ (with-xtm2.0 (tm revision) (export-to-elem tm #'(lambda(elem) (to-elem elem revision)))) - (with-xtm1.0 + (with-xtm1.0 (tm revision) (export-to-elem tm #'(lambda(elem) (to-elem-xtm1.0 elem revision))))))))))) @@ -117,7 +119,7 @@ (with-xtm2.0 (tm revision) (export-to-elem tm #'(lambda(elem) (to-elem elem revision)))) - (with-xtm1.0 + (with-xtm1.0 (tm revision) (export-to-elem tm #'(lambda(elem) (to-elem-xtm1.0 elem revision)))))))))) @@ -130,5 +132,5 @@ (if (eq xtm-format '2.0) (with-xtm2.0 (nil nil) (to-elem fragment (revision fragment))) - (with-xtm1.0 + (with-xtm1.0 (nil nil) (to-elem-xtm1.0 fragment (revision fragment)))))))) \ No newline at end of file Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Sat Oct 16 12:15:50 2010 @@ -549,4 +549,7 @@ (format t "a") (from-association-elem-xtm1.0 assoc-elem revision :tm tm - :xtm-id xtm-id)))))) + :xtm-id xtm-id)) + (let ((reifier-topic (get-reifier-topic-xtm1.0 xtm-dom revision))) + (when reifier-topic + (add-reifier tm reifier-topic :revision revision))))))) \ No newline at end of file

1 0

[isidorus-cvs] r329 - in trunk/src: . model unit_tests xml/xtm
by Lukas Giessmann 16 Oct '10

16 Oct '10

Author: lgiessmann Date: Sat Oct 16 09:52:28 2010 New Revision: 329 Log: fixed ticket #63 and ticket #64 --> the xtm 2.0 importer/exporter is able to handle item-identifiers of TopicMap-elements and also to merge TopicMap-elements; added a unit-test for the new functionality Added: trunk/src/unit_tests/poems_light_tm_ii.xtm trunk/src/unit_tests/poems_light_tm_ii_merge.xtm Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/unit_tests/importer_test.lisp trunk/src/unit_tests/unittests-constants.lisp trunk/src/xml/xtm/exporter.lisp trunk/src/xml/xtm/exporter_xtm2.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sat Oct 16 09:52:28 2010 @@ -113,6 +113,8 @@ (:static-file "poems.rdf") (:static-file "poems_light.rdf") (:static-file "poems_light.xtm") + (:static-file "poems_light_tm_ii.xtm") + (:static-file "poems_light_tm_ii_merge.xtm") (:static-file "full_mapping.rdf") (:static-file "reification_xtm1.0.xtm") (:static-file "reification_xtm2.0.xtm") Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sat Oct 16 09:52:28 2010 @@ -1177,7 +1177,7 @@ (setf (end-revision last-version) revision))))) -;;; TopicMapconstructC +;;; TopicMapConstructC (defgeneric strictly-equivalent-constructs (construct-1 construct-2 &key revision) (:documentation "Checks if two topic map constructs are not identical but @@ -3487,10 +3487,11 @@ ;;; TopicMapC (defmethod equivalent-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC) &key (revision *TM-REVISION*)) - (declare (integer revision)) - (when (intersection (item-identifiers construct-1 :revision revision) - (item-identifiers construct-2 :revision revision)) - t)) + "In this definition TopicMaps are alwayas equal, + since item-identifiers and reifiers are not changing the result of + the TMDM equality." + (declare (ignorable revision)) + t) (defgeneric TopicMapC-p (class-symbol) Modified: trunk/src/unit_tests/importer_test.lisp ============================================================================== --- trunk/src/unit_tests/importer_test.lisp (original) +++ trunk/src/unit_tests/importer_test.lisp Sat Oct 16 09:52:28 2010 @@ -39,7 +39,8 @@ :test-topic-t100 :test-topicmaps :test-variants - :test-variants-xtm1.0)) + :test-variants-xtm1.0 + :test-merge-topicmaps)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) (in-package :importer-test) @@ -683,8 +684,49 @@ tms) :test #'string=))))) - -;as (importer-test:run-importer-tests) +(test test-merge-topicmaps + (let ((dir "data_base") + (tm-id-1 "tm-id-1") + (tm-id-2 "tm-id-2")) + (with-fixture with-empty-db (dir) + (xml-importer:setup-repository *poems_light_tm_ii.xtm* + dir :tm-id tm-id-1) + (xml-importer:import-xtm *poems_light_tm_ii_merge.xtm* + dir :tm-id tm-id-2) + (with-revision 0 + (let ((tm-1 + (d:identified-construct + (first (elephant:get-instances-by-value + 'd:ItemIdentifierC 'd:uri tm-id-1)))) + (tm-2 + (d:identified-construct + (first (elephant:get-instances-by-value + 'd:ItemIdentifierC 'd:uri tm-id-2))))) + (is-true tm-1) + (is-true tm-2) + (is (eql tm-1 tm-2)) + (is-false (set-exclusive-or (map 'list #'d:uri (item-identifiers tm-1)) + (list tm-id-1 tm-id-2 + "http://some.where/poems_light_tm_ii_1" + "http://some.where/poems_light_tm_ii_2") + :test #'string=)) + (is (= (length (d:topics tm-1)) 9)) + (is (= (length (d:associations tm-1)) (+ 1 3))) + (is (= (length (d:in-topicmaps (d:get-item-by-id "schiller"))) 1)) + (is (eql (first (d:in-topicmaps (d:get-item-by-id "schiller"))) tm-1)) + + + (let ((schiller-1 (d:get-item-by-id + "schiller" + :revision (first (last (d:get-all-revisions))))) + (schiller-2 (d:get-item-by-id + "schiller" + :revision (elt (d:get-all-revisions) + (- (length (d:get-all-revisions)) 2))))) + (is-true schiller-1) + (is-false schiller-2))))))) + + (defun run-importer-tests () (run! 'importer-test)) Added: trunk/src/unit_tests/poems_light_tm_ii.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/poems_light_tm_ii.xtm Sat Oct 16 09:52:28 2010 @@ -0,0 +1,69 @@ +<?xml version="1.0" encoding="UTF-8"?> + + + + + + + + + + + + +<tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/" + reifier="http://some.where/poems/topicMap-reifier"> +  + <tm:itemIdentity href="http://some.where/poems_light_tm_ii_1"/> + + <tm:itemIdentity href="http://some.where/poems_light_tm_ii_2"/> + + <tm:topic id="topicMap-reifier"> + <tm:itemIdentity href="http://some.where/poems/topicMap-reifier"/> + </tm:topic> + + <tm:topic id="author"> + <tm:subjectIdentifier href="http://some.where/types/Author"/> + </tm:topic> + + <tm:topic id="poem"> + <tm:subjectIdentifier href="http://some.where/types/Poem"/> + </tm:topic> + + <tm:topic id="writer"> + <tm:subjectIdentifier href="http://some.where/roletype/writer"/> + </tm:topic> + + <tm:topic id="written"> + <tm:subjectIdentifier href="http://some.where/roletype/written"/> + </tm:topic> + + <tm:topic id="wrote"> + <tm:subjectIdentifier href="http://some.where/relationship/wrote"/> + </tm:topic> + + <tm:topic id="goethe"> + <tm:subjectIdentifier href="http://some.where/author/Goethe"/> + <tm:instanceOf><tm:topicRef href="#author"/></tm:instanceOf> + </tm:topic> + + <tm:topic id="zauberlehrling"> + <tm:subjectIdentifier href="http://some.where/poem/Der_Zauberlehrling"/> + <tm:itemIdentity href="http://some.where/poem/Zauberlehrling_itemIdentity_1"/> + <tm:instanceOf><tm:topicRef href="#poem"/></tm:instanceOf> + </tm:topic> + + <tm:association> + <tm:type><tm:topicRef href="#wrote"/></tm:type> + <tm:role> + <tm:type><tm:topicRef href="#writer"/></tm:type> + <tm:topicRef href="#goethe"/> + </tm:role> + <tm:role> + <tm:type><tm:topicRef href="#written"/></tm:type> + <tm:topicRef href="#zauberlehrling"/> + </tm:role> + </tm:association> +</tm:topicMap> Added: trunk/src/unit_tests/poems_light_tm_ii_merge.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/poems_light_tm_ii_merge.xtm Sat Oct 16 09:52:28 2010 @@ -0,0 +1,28 @@ +<?xml version="1.0" encoding="UTF-8"?> + + + + + + + + + + + + +<tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/"> +  + <tm:itemIdentity href="http://some.where/poems_light_tm_ii_1"/> + + <tm:topic id="author"> + <tm:subjectIdentifier href="http://some.where/types/Author"/> + </tm:topic> + + <tm:topic id="schiller"> + <tm:subjectIdentifier href="http://some.where/author/Schiller"/> + <tm:instanceOf><tm:topicRef href="#author"/></tm:instanceOf> + </tm:topic> +</tm:topicMap> Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Sat Oct 16 09:52:28 2010 @@ -34,7 +34,9 @@ :*full_mapping.rdf* :*reification_xtm1.0.xtm* :*reification_xtm2.0.xtm* - :*reification.rdf*)) + :*reification.rdf* + :*poems_light_tm_ii.xtm* + :*poems_light_tm_ii_merge.xtm*)) (in-package :unittests-constants) @@ -119,3 +121,13 @@ (defparameter *reification.rdf* (asdf:component-pathname (asdf:find-component *unit-tests-component* "reification.rdf"))) + + +(defparameter *poems_light_tm_ii.xtm* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "poems_light_tm_ii.xtm"))) + + +(defparameter *poems_light_tm_ii_merge.xtm* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "poems_light_tm_ii_merge.xtm"))) Modified: trunk/src/xml/xtm/exporter.lisp ============================================================================== --- trunk/src/xml/xtm/exporter.lisp (original) +++ trunk/src/xml/xtm/exporter.lisp Sat Oct 16 09:52:28 2010 @@ -39,12 +39,17 @@ collect item))) -(defmacro with-xtm2.0 (&body body) +(defmacro with-xtm2.0 ((tm revision) &body body) "helper macro to build the Topic Map element" `(cxml:with-namespace ("t" *xtm2.0-ns*) (cxml:with-element "t:topicMap" :empty (cxml:attribute "version" "2.0") + (when ,tm + (to-reifier-elem ,tm ,revision) + (map 'list #'(lambda(x) + (to-elem x ,revision)) + (item-identifiers ,tm :revision ,revision))) ,@body))) @@ -54,7 +59,7 @@ (cxml:with-namespace ("xlink" *xtm1.0-xlink*) (cxml:with-element "t:topicMap" :empty - ,@body)))) + ,@body)))) (defmacro export-to-elem (tm to-elem) @@ -90,7 +95,7 @@ (with-open-file (stream xtm-path :direction :output) (cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil) (if (eq xtm-format '2.0) - (with-xtm2.0 + (with-xtm2.0 (tm revision) (export-to-elem tm #'(lambda(elem) (to-elem elem revision)))) (with-xtm1.0 @@ -109,7 +114,7 @@ (with-revision revision (cxml:with-xml-output (cxml:make-string-sink :canonical nil) (if (eq xtm-format '2.0) - (with-xtm2.0 + (with-xtm2.0 (tm revision) (export-to-elem tm #'(lambda(elem) (to-elem elem revision)))) (with-xtm1.0 @@ -123,7 +128,7 @@ (with-revision (revision fragment) (cxml:with-xml-output (cxml:make-string-sink :canonical nil) (if (eq xtm-format '2.0) - (with-xtm2.0 + (with-xtm2.0 (nil nil) (to-elem fragment (revision fragment))) (with-xtm1.0 (to-elem-xtm1.0 fragment (revision fragment)))))))) \ No newline at end of file Modified: trunk/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm2.0.lisp Sat Oct 16 09:52:28 2010 @@ -13,7 +13,7 @@ "Exports the reifier-attribute. The attribute is only exported if the reifier-topic contains at least one item-identifier." - (declare (ReifiableConstructC reifiable-construct) + (declare (type (or ReifiableConstructC nil) reifiable-construct) (type (or integer nil) revision)) (when (and (reifier reifiable-construct :revision revision) (item-identifiers (reifier reifiable-construct :revision revision) Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Sat Oct 16 09:52:28 2010 @@ -396,6 +396,7 @@ (xpath-child-elems-by-qname xtm-dom *xtm2.0-ns* "association")) + (defun import-only-topics (xtm-dom &key @@ -417,13 +418,15 @@ (xtm-id d:*current-xtm*) (revision (get-revision))) (declare (dom:element xtm-dom)) - (declare (integer revision)) ;all topics that are imported in one go share the same revision + (declare (integer revision)) + ;all topics/associations that are imported in one go share the same revision (assert elephant:*store-controller*) (with-writer-lock (with-tm (revision xtm-id tm-id) - (let - ((topic-vector (get-topic-elems xtm-dom)) - (assoc-vector (get-association-elems xtm-dom))) + (let ((topic-vector (get-topic-elems xtm-dom)) + (assoc-vector (get-association-elems xtm-dom)) + (tm-ids + (make-identifiers 'ItemIdentifierC xtm-dom "itemIdentity" revision))) (loop for top-elem across topic-vector do (from-topic-elem-to-stub top-elem revision :xtm-id xtm-id)) @@ -436,4 +439,10 @@ (format t "a") (from-association-elem assoc-elem revision :tm tm - :xtm-id xtm-id)))))) + :xtm-id xtm-id)) + (loop for tm-id in tm-ids do + (add-item-identifier tm tm-id :revision revision)) + (let ((reifier-topic (get-reifier-topic xtm-dom revision))) + (when reifier-topic + (add-reifier tm reifier-topic :revision revision))))))) + \ No newline at end of file

1 0

[isidorus-cvs] r328 - in trunk: docs playground src src/ajax src/ajax/css src/ajax/javascripts src/atom src/json src/model src/rest_interface src/threading src/unit_tests src/xml/rdf src/xml/xtm
by Lukas Giessmann 15 Oct '10

15 Oct '10

Author: lgiessmann Date: Fri Oct 15 15:03:24 2010 New Revision: 328 Log: fixed ticket #75 --> changed license terms from LGPL to LLGPL in the trunk tree Added: trunk/docs/LLGPL-LICENSE.txt Modified: trunk/docs/install_isidorus.txt trunk/playground/call-next-method.lisp trunk/playground/call-next-method_multiple-inheritance.lisp trunk/playground/ii_versioned_association.lisp trunk/playground/isidorus_test.sh trunk/playground/system_crash.lisp trunk/playground/threading_debugging.lisp trunk/playground/url_test.html trunk/playground/url_test.js trunk/playground/versioned-pointer.lisp trunk/src/ajax/css/frame.css trunk/src/ajax/css/main.css trunk/src/ajax/css/navi.css trunk/src/ajax/css/tree.css trunk/src/ajax/isidorus.html trunk/src/ajax/javascripts/constants.js trunk/src/ajax/javascripts/create.js trunk/src/ajax/javascripts/datamodel.js trunk/src/ajax/javascripts/edit.js trunk/src/ajax/javascripts/home.js trunk/src/ajax/javascripts/navi.js trunk/src/ajax/javascripts/requests.js trunk/src/ajax/javascripts/search.js trunk/src/ajax/javascripts/tmcl_tools.js trunk/src/atom/atom.lisp trunk/src/atom/collection.lisp trunk/src/atom/conf.lisp trunk/src/atom/configuration.lisp trunk/src/atom/confreader.lisp trunk/src/atom/fragments.lisp trunk/src/atom/read.lisp trunk/src/atom/snapshots.lisp trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/json/json_delete_interface.lisp trunk/src/json/json_exporter.lisp trunk/src/json/json_importer.lisp trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_constants.lisp trunk/src/json/json_tmcl_validation.lisp trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp trunk/src/model/exceptions.lisp trunk/src/model/model_tools.lisp trunk/src/rest_interface/publish_feeds.lisp trunk/src/rest_interface/read.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/threading/reader-writer.lisp trunk/src/unit_tests/atom-conf.lisp trunk/src/unit_tests/atom_test.lisp trunk/src/unit_tests/atom_test.xtm trunk/src/unit_tests/dangling_instanceof.xtm trunk/src/unit_tests/dangling_topicref.xtm trunk/src/unit_tests/datamodel_test.lisp trunk/src/unit_tests/duplicate_identifier.xtm trunk/src/unit_tests/exporter_xtm1.0_test.lisp trunk/src/unit_tests/exporter_xtm2.0_test.lisp trunk/src/unit_tests/fixtures.lisp trunk/src/unit_tests/full_mapping.rdf trunk/src/unit_tests/importer_test.lisp trunk/src/unit_tests/inconsistent.xtm trunk/src/unit_tests/inconsistent_2_0.xtm trunk/src/unit_tests/json_test.lisp trunk/src/unit_tests/multiple_tms_ont.xtm trunk/src/unit_tests/multiple_tms_worms.xtm trunk/src/unit_tests/notification_merge1.xtm trunk/src/unit_tests/notification_merge2.xtm trunk/src/unit_tests/notificationbase.xtm trunk/src/unit_tests/poems.rdf trunk/src/unit_tests/poems.xtm trunk/src/unit_tests/poems_light.rdf trunk/src/unit_tests/poems_light.xtm trunk/src/unit_tests/rdf_exporter_test.lisp trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/unit_tests/reification.rdf trunk/src/unit_tests/reification_test.lisp trunk/src/unit_tests/reification_xtm1.0.xtm trunk/src/unit_tests/reification_xtm2.0.xtm trunk/src/unit_tests/sample_objects.xtm trunk/src/unit_tests/sample_objects_2_0.xtm trunk/src/unit_tests/t100.xtm trunk/src/unit_tests/testing_db.lisp trunk/src/unit_tests/textgrid.xtm trunk/src/unit_tests/threading_test.lisp trunk/src/unit_tests/unittests-constants.lisp trunk/src/unit_tests/versions_test.lisp trunk/src/xml-constants.lisp trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_core_psis.xtm trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/core_psis.xtm trunk/src/xml/xtm/exporter.lisp trunk/src/xml/xtm/exporter_xtm1.0.lisp trunk/src/xml/xtm/exporter_xtm2.0.lisp trunk/src/xml/xtm/importer.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp trunk/src/xml/xtm/setup.lisp trunk/src/xml/xtm/tools.lisp Added: trunk/docs/LLGPL-LICENSE.txt ============================================================================== --- (empty file) +++ trunk/docs/LLGPL-LICENSE.txt Fri Oct 15 15:03:24 2010 @@ -0,0 +1,14 @@ +Preamble to the Gnu Lesser General Public License +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been adopted to govern the use and distribution of above-mentioned application. However, the LGPL uses terminology that is more appropriate for a program written in C than one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if certain clarifications are made. This document details those clarifications. Accordingly, the license for the open-source Lisp applications consists of this document plus the LGPL. Wherever there is a conflict between this document and the LGPL, this document takes precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. The form of the Library can be Lisp source code (for processing by an interpreter) or object code (usually the result of compilation of source code or built with some other mechanisms). Foreign modules are object code in a form that can be linked into a Lisp executable. When we speak of functions we do so in the most general way to include, in addition, methods and unnamed functions. Lisp "data" is also a general term that includes the data structures resulting from defining Lisp classes. A Lisp application may include the same set of Lisp objects as does a Library, but this does not mean that the application is necessarily a "work based on the Library" it contains. + +The Library consists of everything in the distribution file set before any modifications are made to the files. If any of the functions or classes in the Library are redefined in other files, then those redefinitions ARE considered a work based on the Library. If additional methods are added to generic functions in the Library, those additional methods are NOT considered a work based on the Library. If Library classes are subclassed, these subclasses are NOT considered a work based on the Library. If the Library is modified to explicitly call other functions that are neither part of Lisp itself nor an available add-on module to Lisp, then the functions called by the modified Library ARE considered a work based on the Library. The goal is to ensure that the Library will compile and run without getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it must be done in a way such that the Library will still run without that proprietary code present. Section 5 of the LGPL distinguishes between the case of a library being dynamically linked at runtime and one being statically linked at build time. Section 5 of the LGPL states that the former results in an executable that is a "work that uses the Library." Section 5 of the LGPL states that the latter results in one that is a "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only offers one choice, which is to link the Library into an executable at build time, we declare that, for the purpose applying the LGPL to the Library, an executable that results from linking a "work that uses the Library" with the Library is considered a "work that uses the Library" and is therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to the Library. However, in connection with each distribution of this executable, you must also deliver, in accordance with the terms and conditions of the LGPL, the source code of Library (or your derivative thereof) that is incorporated into this executable. + +End of Document Modified: trunk/docs/install_isidorus.txt ============================================================================== --- trunk/docs/install_isidorus.txt (original) +++ trunk/docs/install_isidorus.txt Fri Oct 15 15:03:24 2010 @@ -5,6 +5,17 @@ http://trac.common-lisp.net/isidorus/wiki/InstallIsidorus + +License Terms +============= +(c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff + +Isidorus is freely distributable under the LLGPL license. +You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +trunk/docs/LGPL-LICENSE.txt. + + + Starting Isidorus ===================== Modified: trunk/playground/call-next-method.lisp ============================================================================== --- trunk/playground/call-next-method.lisp (original) +++ trunk/playground/call-next-method.lisp Fri Oct 15 15:03:24 2010 @@ -1,3 +1,13 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + (defclass Class-1 () ((value :initarg :value :accessor value))) Modified: trunk/playground/call-next-method_multiple-inheritance.lisp ============================================================================== --- trunk/playground/call-next-method_multiple-inheritance.lisp (original) +++ trunk/playground/call-next-method_multiple-inheritance.lisp Fri Oct 15 15:03:24 2010 @@ -1,3 +1,13 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + (defclass CharacteristicC() ((value :accessor value :initarg :value Modified: trunk/playground/ii_versioned_association.lisp ============================================================================== --- trunk/playground/ii_versioned_association.lisp (original) +++ trunk/playground/ii_versioned_association.lisp Fri Oct 15 15:03:24 2010 @@ -1,3 +1,13 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + (asdf:operate 'asdf:load-op 'elephant) (use-package :elephant) Modified: trunk/playground/isidorus_test.sh ============================================================================== --- trunk/playground/isidorus_test.sh (original) +++ trunk/playground/isidorus_test.sh Fri Oct 15 15:03:24 2010 @@ -1,5 +1,15 @@ #!/bin/bash +#+----------------------------------------------------------------------------- +#+ Isidorus +#+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +#+ +#+ Isidorus is freely distributable under the LLGPL license. +#+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +#+ trunk/docs/LGPL-LICENSE.txt. +#+----------------------------------------------------------------------------- + + host="http://192.168.0.6:8000"; wDir="isidorus_test"; Modified: trunk/playground/system_crash.lisp ============================================================================== --- trunk/playground/system_crash.lisp (original) +++ trunk/playground/system_crash.lisp Fri Oct 15 15:03:24 2010 @@ -1,3 +1,13 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + (sb-mop:class-slots (find-class 'd:ItemIdentifierC)) (sb-mop:class-finalized-p (find-class 'd:ItemIdentifierC)) (sb-mop:finalize-inheritance (find-class 'd:ItemIdentifierC)) Modified: trunk/playground/threading_debugging.lisp ============================================================================== --- trunk/playground/threading_debugging.lisp (original) +++ trunk/playground/threading_debugging.lisp Fri Oct 15 15:03:24 2010 @@ -1,3 +1,13 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + (require :asdf) (asdf:operate 'asdf:load-op :isidorus) (xml-importer:setup-repository "textgrid.xtm" "data_base" Modified: trunk/playground/url_test.html ============================================================================== --- trunk/playground/url_test.html (original) +++ trunk/playground/url_test.html Fri Oct 15 15:03:24 2010 @@ -1,12 +1,13 @@   - +  - +   - - + + +  Modified: trunk/playground/url_test.js ============================================================================== --- trunk/playground/url_test.js (original) +++ trunk/playground/url_test.js Fri Oct 15 15:03:24 2010 @@ -1,3 +1,15 @@ +//+----------------------------------------------------------------------------- +//+ Isidorus +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +//+ +//+ Isidorus is freely distributable under the LLGPL license. +//+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both +//+ are distributed under the MIT license. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+----------------------------------------------------------------------------- + function entryPoint(){ var elem = getElem(); var url = window.location.href; Modified: trunk/playground/versioned-pointer.lisp ============================================================================== --- trunk/playground/versioned-pointer.lisp (original) +++ trunk/playground/versioned-pointer.lisp Fri Oct 15 15:03:24 2010 @@ -1,3 +1,12 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + (asdf:operate 'asdf:load-op 'elephant) (elephant:open-store '(:BDB "data_base")) (defpclass Relation() Modified: trunk/src/ajax/css/frame.css ============================================================================== --- trunk/src/ajax/css/frame.css (original) +++ trunk/src/ajax/css/frame.css Fri Oct 15 15:03:24 2010 @@ -1,13 +1,15 @@ /*----------------------------------------------------------------------------*/ /* Isidorus */ -/* (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann */ +/* (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff */ /* */ -/* Isidorus is freely distributable under the LGPL license. */ +/* Isidorus is freely distributable under the LLGPL license. */ /* This ajax module uses the frameworks PrototypeJs and Scriptaculous, both */ /* are distributed under the MIT license. */ -/* You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and */ -/* in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ +/* You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, */ +/* trunk/docs/LGPL-LICENSE.txt and in */ +/* trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ /*----------------------------------------------------------------------------*/ + ul.fragmentFrame { list-style-type: none; padding-left: 0px; Modified: trunk/src/ajax/css/main.css ============================================================================== --- trunk/src/ajax/css/main.css (original) +++ trunk/src/ajax/css/main.css Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ /*----------------------------------------------------------------------------*/ /* Isidorus */ -/* (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann */ +/* (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff */ /* */ -/* Isidorus is freely distributable under the LGPL license. */ +/* Isidorus is freely distributable under the LLGPL license. */ /* This ajax module uses the frameworks PrototypeJs and Scriptaculous, both */ /* are distributed under the MIT license. */ -/* You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and */ -/* in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ +/* You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, */ +/* trunk/docs/LGPL-LICENSE.txt and in */ +/* trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ /*----------------------------------------------------------------------------*/ - body { width: 1024px; margin-left: auto; Modified: trunk/src/ajax/css/navi.css ============================================================================== --- trunk/src/ajax/css/navi.css (original) +++ trunk/src/ajax/css/navi.css Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ /*----------------------------------------------------------------------------*/ /* Isidorus */ -/* (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann */ +/* (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff */ /* */ -/* Isidorus is freely distributable under the LGPL license. */ +/* Isidorus is freely distributable under the LLGPL license. */ /* This ajax module uses the frameworks PrototypeJs and Scriptaculous, both */ /* are distributed under the MIT license. */ -/* You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and */ -/* in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ +/* You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, */ +/* trunk/docs/LGPL-LICENSE.txt and in */ +/* trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ /*----------------------------------------------------------------------------*/ - #navi { background-color: #aebae3; width: 1022px; Modified: trunk/src/ajax/css/tree.css ============================================================================== --- trunk/src/ajax/css/tree.css (original) +++ trunk/src/ajax/css/tree.css Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ /*----------------------------------------------------------------------------*/ /* Isidorus */ -/* (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann */ +/* (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff */ /* */ -/* Isidorus is freely distributable under the LGPL license. */ +/* Isidorus is freely distributable under the LLGPL license. */ /* This ajax module uses the frameworks PrototypeJs and Scriptaculous, both */ /* are distributed under the MIT license. */ -/* You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and */ -/* in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ +/* You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, */ +/* trunk/docs/LGPL-LICENSE.txt and in */ +/* trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. */ /*----------------------------------------------------------------------------*/ - ul.treeView { padding-top: 10px; padding-left: 20px; Modified: trunk/src/ajax/isidorus.html ============================================================================== --- trunk/src/ajax/isidorus.html (original) +++ trunk/src/ajax/isidorus.html Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@   - +  - +   - - + + +  - <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - // --- Some constants fot the http connections via the XMLHttpRequest-Object var HOST_PREF = getHostPref(); var GET_PREFIX = HOST_PREF + "json/get/"; Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - // --- Creates the "create"-sub-page. function makeCreate(psi) { Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Fri Oct 15 15:03:24 2010 @@ -1,12 +1,13 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- // --- The base class of all Frames defined in this file. Modified: trunk/src/ajax/javascripts/edit.js ============================================================================== --- trunk/src/ajax/javascripts/edit.js (original) +++ trunk/src/ajax/javascripts/edit.js Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - function makeEdit(psi) { var content = new Element("div", {"class" : CLASSES.content()}); Modified: trunk/src/ajax/javascripts/home.js ============================================================================== --- trunk/src/ajax/javascripts/home.js (original) +++ trunk/src/ajax/javascripts/home.js Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - function makeHome() { var content = new Element("div", {"class" : CLASSES.content()}); Modified: trunk/src/ajax/javascripts/navi.js ============================================================================== --- trunk/src/ajax/javascripts/navi.js (original) +++ trunk/src/ajax/javascripts/navi.js Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - // --- adds some event handlers to the navigation elements function addHandlersToNavi() { Modified: trunk/src/ajax/javascripts/requests.js ============================================================================== --- trunk/src/ajax/javascripts/requests.js (original) +++ trunk/src/ajax/javascripts/requests.js Fri Oct 15 15:03:24 2010 @@ -1,16 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - - // --- Sets a timeout function which alerts a message. function setAjaxTimeout(time, url) { Modified: trunk/src/ajax/javascripts/search.js ============================================================================== --- trunk/src/ajax/javascripts/search.js (original) +++ trunk/src/ajax/javascripts/search.js Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - function makeSearch(psi) { var content = new Element("div", {"class" : CLASSES.content()}); Modified: trunk/src/ajax/javascripts/tmcl_tools.js ============================================================================== --- trunk/src/ajax/javascripts/tmcl_tools.js (original) +++ trunk/src/ajax/javascripts/tmcl_tools.js Fri Oct 15 15:03:24 2010 @@ -1,15 +1,15 @@ //+----------------------------------------------------------------------------- //+ Isidorus -//+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +//+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff //+ -//+ Isidorus is freely distributable under the LGPL license. +//+ Isidorus is freely distributable under the LLGPL license. //+ This ajax module uses the frameworks PrototypeJs and Scriptaculous, both //+ are distributed under the MIT license. -//+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt and -//+ in trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. +//+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt, and +//+ trunk/docs/LGPL-LICENSE.txt in +//+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- - // --- Returns an Array of the type [<boolean>, <string>]. // --- If there are exclusive-instance-constraints, the return value is an array // --- of the form [false, "message"] otherwise [true, ""]. Modified: trunk/src/atom/atom.lisp ============================================================================== --- trunk/src/atom/atom.lisp (original) +++ trunk/src/atom/atom.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :atom (:use :cl :cxml :constants :xml-tools :datamodel :drakma :isidorus-threading) (:export :collection-feed Modified: trunk/src/atom/collection.lisp ============================================================================== --- trunk/src/atom/collection.lisp (original) +++ trunk/src/atom/collection.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :atom) (defclass collection-feed (feed) Modified: trunk/src/atom/conf.lisp ============================================================================== --- trunk/src/atom/conf.lisp (original) +++ trunk/src/atom/conf.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :atom) (defsite psi.egovpt.org ;;(base-url "http://london.ztt.fh-worms.de:8000") ;the base-url Modified: trunk/src/atom/configuration.lisp ============================================================================== --- trunk/src/atom/configuration.lisp (original) +++ trunk/src/atom/configuration.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :atom) ;the configuration of the eGov application (at present) ;TODO: convert to an XML configuration file for the site Modified: trunk/src/atom/confreader.lisp ============================================================================== --- trunk/src/atom/confreader.lisp (original) +++ trunk/src/atom/confreader.lisp Fri Oct 15 15:03:24 2010 @@ -1,16 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - -;; (defmacro site (&body lines) -;; `(dolist (line (quote ,lines)) -;; (format t "~a~&" line))) - (in-package :atom) (defmacro get-conflist (sym conflines) Modified: trunk/src/atom/fragments.lisp ============================================================================== --- trunk/src/atom/fragments.lisp (original) +++ trunk/src/atom/fragments.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :atom) (defclass fragment-entry (entry) Modified: trunk/src/atom/read.lisp ============================================================================== --- trunk/src/atom/read.lisp (original) +++ trunk/src/atom/read.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :atom) (defmacro parse-feed ((feed-string feed-type) &body make-entry) Modified: trunk/src/atom/snapshots.lisp ============================================================================== --- trunk/src/atom/snapshots.lisp (original) +++ trunk/src/atom/snapshots.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :atom) (defclass snapshots-feed (feed) Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Fri Oct 15 15:03:24 2010 @@ -1,13 +1,12 @@ - ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :constants (:use :cl) (:export :*atom-ns* Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Fri Oct 15 15:03:24 2010 @@ -1,13 +1,13 @@ ;;-*- mode: lisp -*- ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :isidorus-system (:use :asdf :cl)) (in-package :isidorus-system) @@ -18,7 +18,7 @@ (asdf:defsystem "isidorus" :description "The future ingenious, self-evaluating Lisp TM engine" :version "0.1" - :author "Marc Kuester, Christoph Ludwig, Lukas Giessmann" + :author "Marc Kuester, Christoph Ludwig, Lukas Georgieff" :licence "LGPL" :components ( (:file "constants") Modified: trunk/src/json/json_delete_interface.lisp ============================================================================== --- trunk/src/json/json_delete_interface.lisp (original) +++ trunk/src/json/json_delete_interface.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :json-delete-interface (:use :cl :datamodel :json-importer) (:export :mark-as-deleted-from-json)) Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :json-exporter (:use :cl :json :datamodel) (:export :to-json-string Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :json-importer (:use :cl :json :datamodel :xml-importer) (:export :json-to-elem Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :json-tmcl) Modified: trunk/src/json/json_tmcl_constants.lisp ============================================================================== --- trunk/src/json/json_tmcl_constants.lisp (original) +++ trunk/src/json/json_tmcl_constants.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :json-tmcl-constants (:use :cl) (:export :*schema-psi* Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :json-tmcl (:use :cl :datamodel :constants :json-tmcl-constants :json-importer) (:export :get-constraints-of-fragment Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp (original) +++ trunk/src/model/changes.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :datamodel) (defun get-all-revisions () Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :datamodel (:use :cl :elephant :constants) (:nicknames :d) Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :exceptions (:use :common-lisp) (:export :inconsistent-file-error Modified: trunk/src/model/model_tools.lisp ============================================================================== --- trunk/src/model/model_tools.lisp (original) +++ trunk/src/model/model_tools.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :datamodel) (defgeneric equalT (construct1 construct2) Modified: trunk/src/rest_interface/publish_feeds.lisp ============================================================================== --- trunk/src/rest_interface/publish_feeds.lisp (original) +++ trunk/src/rest_interface/publish_feeds.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :rest-interface) (defgeneric publish-feed (feed) Modified: trunk/src/rest_interface/read.lisp ============================================================================== --- trunk/src/rest_interface/read.lisp (original) +++ trunk/src/rest_interface/read.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :rest-interface) ;in the midterm write a reader thread Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :rest-interface (:nicknames :rest) (:use :cl :hunchentoot 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 Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :rest-interface) ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> Modified: trunk/src/threading/reader-writer.lisp ============================================================================== --- trunk/src/threading/reader-writer.lisp (original) +++ trunk/src/threading/reader-writer.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :isidorus-threading (:use :cl :bordeaux-threads) (:export :current-readers Modified: trunk/src/unit_tests/atom-conf.lisp ============================================================================== --- trunk/src/unit_tests/atom-conf.lisp (original) +++ trunk/src/unit_tests/atom-conf.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :atom) (defsite psi.egovpt.org ;;(base-url "http://london.ztt.fh-worms.de:8000") ;the base-url Modified: trunk/src/unit_tests/atom_test.lisp ============================================================================== --- trunk/src/unit_tests/atom_test.lisp (original) +++ trunk/src/unit_tests/atom_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :atom-test (:use :common-lisp Modified: trunk/src/unit_tests/atom_test.xtm ============================================================================== --- trunk/src/unit_tests/atom_test.xtm (original) +++ trunk/src/unit_tests/atom_test.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0">  <itemIdentity href="http://psi.egovpt.org/tm/egov-ontology"/> Modified: trunk/src/unit_tests/dangling_instanceof.xtm ============================================================================== --- trunk/src/unit_tests/dangling_instanceof.xtm (original) +++ trunk/src/unit_tests/dangling_instanceof.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> <topic id="t1"> <itemIdentity href="http://psi.egovpt.org/itemIdentifiers#t1"/> Modified: trunk/src/unit_tests/dangling_topicref.xtm ============================================================================== --- trunk/src/unit_tests/dangling_topicref.xtm (original) +++ trunk/src/unit_tests/dangling_topicref.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> <topic id="t-1"> <itemIdentity href="http://psi.egovpt.org/itemIdentifiers#t1"/> Modified: trunk/src/unit_tests/datamodel_test.lisp ============================================================================== --- trunk/src/unit_tests/datamodel_test.lisp (original) +++ trunk/src/unit_tests/datamodel_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :datamodel-test (:use :common-lisp Modified: trunk/src/unit_tests/duplicate_identifier.xtm ============================================================================== --- trunk/src/unit_tests/duplicate_identifier.xtm (original) +++ trunk/src/unit_tests/duplicate_identifier.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> <topic id="t1"> <itemIdentity href="http://psi.egovpt.org/itemIdentifiers#t1"/> Modified: trunk/src/unit_tests/exporter_xtm1.0_test.lisp ============================================================================== --- trunk/src/unit_tests/exporter_xtm1.0_test.lisp (original) +++ trunk/src/unit_tests/exporter_xtm1.0_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :exporter-test) (in-suite exporter-tests) Modified: trunk/src/unit_tests/exporter_xtm2.0_test.lisp ============================================================================== --- trunk/src/unit_tests/exporter_xtm2.0_test.lisp (original) +++ trunk/src/unit_tests/exporter_xtm2.0_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :exporter-test (:use :common-lisp Modified: trunk/src/unit_tests/fixtures.lisp ============================================================================== --- trunk/src/unit_tests/fixtures.lisp (original) +++ trunk/src/unit_tests/fixtures.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :fixtures (:use :common-lisp Modified: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- trunk/src/unit_tests/full_mapping.rdf (original) +++ trunk/src/unit_tests/full_mapping.rdf Fri Oct 15 15:03:24 2010 @@ -1,4 +1,16 @@ <?xml version="1.0" encoding="UTF-8"?> + + + + + + + + + + + + <rdf:RDF xmlns:isi="http://isidorus/tm2rdf_mapping/" xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#" Modified: trunk/src/unit_tests/importer_test.lisp ============================================================================== --- trunk/src/unit_tests/importer_test.lisp (original) +++ trunk/src/unit_tests/importer_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :importer-test (:use :common-lisp Modified: trunk/src/unit_tests/inconsistent.xtm ============================================================================== --- trunk/src/unit_tests/inconsistent.xtm (original) +++ trunk/src/unit_tests/inconsistent.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0" encoding="utf-8"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/1.0/" xmlns:xlink="http://www.w3.org/1999/xlink">  Modified: trunk/src/unit_tests/inconsistent_2_0.xtm ============================================================================== --- trunk/src/unit_tests/inconsistent_2_0.xtm (original) +++ trunk/src/unit_tests/inconsistent_2_0.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0">  Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :json-test (:use :common-lisp Modified: trunk/src/unit_tests/multiple_tms_ont.xtm ============================================================================== --- trunk/src/unit_tests/multiple_tms_ont.xtm (original) +++ trunk/src/unit_tests/multiple_tms_ont.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0" encoding="utf-8"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/1.0/" xmlns:xlink="http://www.w3.org/1999/xlink"> <topic id="t1"> Modified: trunk/src/unit_tests/multiple_tms_worms.xtm ============================================================================== --- trunk/src/unit_tests/multiple_tms_worms.xtm (original) +++ trunk/src/unit_tests/multiple_tms_worms.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0" encoding="utf-8"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/1.0/" xmlns:xlink="http://www.w3.org/1999/xlink"> Modified: trunk/src/unit_tests/notification_merge1.xtm ============================================================================== --- trunk/src/unit_tests/notification_merge1.xtm (original) +++ trunk/src/unit_tests/notification_merge1.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> <topic id="t1"> <itemIdentity href="http://www.egovpt.org/itemIdentifiers#t1"/> Modified: trunk/src/unit_tests/notification_merge2.xtm ============================================================================== --- trunk/src/unit_tests/notification_merge2.xtm (original) +++ trunk/src/unit_tests/notification_merge2.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> <topic id="t1"> <itemIdentity href="http://www.egovpt.org/itemIdentifiers#t1"/> Modified: trunk/src/unit_tests/notificationbase.xtm ============================================================================== --- trunk/src/unit_tests/notificationbase.xtm (original) +++ trunk/src/unit_tests/notificationbase.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> <topic id="t1">  + + + + + + + + + + + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#" xmlns:poems="http://some.where/" Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Fri Oct 15 15:03:24 2010 @@ -1,5 +1,16 @@ <?xml version="1.0" encoding="UTF-8"?> <tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/"> +  +  +  +  +  +  +  +  +  +  +     Modified: trunk/src/unit_tests/poems_light.rdf ============================================================================== --- trunk/src/unit_tests/poems_light.rdf (original) +++ trunk/src/unit_tests/poems_light.rdf Fri Oct 15 15:03:24 2010 @@ -1,4 +1,16 @@ <?xml version="1.0" encoding="UTF-8"?> + + + + + + + + + + + + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#" xmlns:poems="http://some.where/" Modified: trunk/src/unit_tests/poems_light.xtm ============================================================================== --- trunk/src/unit_tests/poems_light.xtm (original) +++ trunk/src/unit_tests/poems_light.xtm Fri Oct 15 15:03:24 2010 @@ -1,4 +1,16 @@ <?xml version="1.0" encoding="UTF-8"?> + + + + + + + + + + + + <tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/">  + + + + + + + + + + + <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#" xmlns:sim="http://simpsons.tv" @@ -100,4 +112,4 @@ <rdf:Description rdf:about="friendship-association"> <arcs:author rdf:resource="http://some.where/me"/> </rdf:Description> -</rdf:RDF> \ No newline at end of file +</rdf:RDF> Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :reification-test (:use :common-lisp Modified: trunk/src/unit_tests/reification_xtm1.0.xtm ============================================================================== --- trunk/src/unit_tests/reification_xtm1.0.xtm (original) +++ trunk/src/unit_tests/reification_xtm1.0.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/1.0/" xmlns:xlink="http://www.w3.org/1999/xlink"> <t:topic xmlns:t="http://www.topicmaps.org/xtm/1.0/" Modified: trunk/src/unit_tests/reification_xtm2.0.xtm ============================================================================== --- trunk/src/unit_tests/reification_xtm2.0.xtm (original) +++ trunk/src/unit_tests/reification_xtm2.0.xtm Fri Oct 15 15:03:24 2010 @@ -1,10 +1,14 @@ <?xml version="1.0"?>   - +  - - + + + + + +  <tm:topicMap xmlns:tm="http://www.topicmaps.org/xtm/" version="2.0"> Modified: trunk/src/unit_tests/sample_objects.xtm ============================================================================== --- trunk/src/unit_tests/sample_objects.xtm (original) +++ trunk/src/unit_tests/sample_objects.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/1.0/" xmlns:xlink="http://www.w3.org/1999/xlink">  Modified: trunk/src/unit_tests/sample_objects_2_0.xtm ============================================================================== --- trunk/src/unit_tests/sample_objects_2_0.xtm (original) +++ trunk/src/unit_tests/sample_objects_2_0.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0">  Modified: trunk/src/unit_tests/t100.xtm ============================================================================== --- trunk/src/unit_tests/t100.xtm (original) +++ trunk/src/unit_tests/t100.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0">  Modified: trunk/src/unit_tests/testing_db.lisp ============================================================================== --- trunk/src/unit_tests/testing_db.lisp (original) +++ trunk/src/unit_tests/testing_db.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (asdf:operate 'asdf:load-op 'FiveAM) (asdf:operate 'asdf:load-op 'cxml) (asdf:operate 'asdf:load-op 'elephant) Modified: trunk/src/unit_tests/textgrid.xtm ============================================================================== --- trunk/src/unit_tests/textgrid.xtm (original) +++ trunk/src/unit_tests/textgrid.xtm Fri Oct 15 15:03:24 2010 @@ -1,5 +1,18 @@ <?xml version="1.0" encoding="UTF-8"?> <tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/"> +  +  +  +  +  +  +  +  +  +  +  + +    Modified: trunk/src/unit_tests/threading_test.lisp ============================================================================== --- trunk/src/unit_tests/threading_test.lisp (original) +++ trunk/src/unit_tests/threading_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :threading-test (:use :cl :it.bese.FiveAM Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :unittests-constants (:use :common-lisp) (:import-from :constants Modified: trunk/src/unit_tests/versions_test.lisp ============================================================================== --- trunk/src/unit_tests/versions_test.lisp (original) +++ trunk/src/unit_tests/versions_test.lisp Fri Oct 15 15:03:24 2010 @@ -1,13 +1,13 @@ +;-*- standard-indent: 2; indent-tabs-mode: nil -*- ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - -;-*- standard-indent: 2; indent-tabs-mode: nil -*- (defpackage :versions-test (:use :common-lisp Modified: trunk/src/xml-constants.lisp ============================================================================== --- trunk/src/xml-constants.lisp (original) +++ trunk/src/xml-constants.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :xml-constants (:use :common-lisp :asdf) Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Fri Oct 15 15:03:24 2010 @@ -1,9 +1,10 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- (defpackage :rdf-exporter Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Fri Oct 15 15:03:24 2010 @@ -1,9 +1,10 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- (in-package :rdf-importer) Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Fri Oct 15 15:03:24 2010 @@ -1,10 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- + (in-package :rdf-importer) (defun map-to-tm (tm-id start-revision Modified: trunk/src/xml/rdf/rdf_core_psis.xtm ============================================================================== --- trunk/src/xml/rdf/rdf_core_psis.xtm (original) +++ trunk/src/xml/rdf/rdf_core_psis.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> <topic id="subject"> Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Fri Oct 15 15:03:24 2010 @@ -1,9 +1,10 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- (defpackage :rdf-importer Modified: trunk/src/xml/xtm/core_psis.xtm ============================================================================== --- trunk/src/xml/xtm/core_psis.xtm (original) +++ trunk/src/xml/xtm/core_psis.xtm Fri Oct 15 15:03:24 2010 @@ -1,13 +1,16 @@ <?xml version="1.0"?>   - +  - - + + + + + +  - <topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0"> Modified: trunk/src/xml/xtm/exporter.lisp ============================================================================== --- trunk/src/xml/xtm/exporter.lisp (original) +++ trunk/src/xml/xtm/exporter.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :exporter) Modified: trunk/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm1.0.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :exporter (:use :cl :cxml :elephant :datamodel :isidorus-threading) (:import-from :constants Modified: trunk/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm2.0.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :exporter) (defun to-reifier-elem (reifiable-construct revision) Modified: trunk/src/xml/xtm/importer.lisp ============================================================================== --- trunk/src/xml/xtm/importer.lisp (original) +++ trunk/src/xml/xtm/importer.lisp Fri Oct 15 15:03:24 2010 @@ -1,9 +1,10 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- @@ -11,9 +12,6 @@ ;; * resolve non-local topicRefs ;; * either check the input document for XTM2.0 conformance in advance or ;; raise some kind of error (--> condition) if something goes wrong. -;; * handle reifier attributes -;; * handle variants -;; (defpackage :xml-importer (:use :cl :cxml :elephant :datamodel :isidorus-threading) Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :xml-importer) (defun get-reifier-topic-xtm1.0 (reifiable-elem start-revision) Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :xml-importer) (defun get-reifier-topic(reifiable-elem start-revision) Modified: trunk/src/xml/xtm/setup.lisp ============================================================================== --- trunk/src/xml/xtm/setup.lisp (original) +++ trunk/src/xml/xtm/setup.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (in-package :xml-importer) (defun get-uuid () Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Fri Oct 15 15:03:24 2010 @@ -1,12 +1,12 @@ ;;+----------------------------------------------------------------------------- ;;+ Isidorus -;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff ;;+ -;;+ Isidorus is freely distributable under the LGPL license. -;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- - (defpackage :xml-tools (:use :cl :cxml) (:import-from :constants

1 0

[isidorus-cvs] r327 - in trunk/src: ajax/javascripts json model rest_interface
by Lukas Giessmann 14 Oct '10

14 Oct '10

Author: lgiessmann Date: Thu Oct 14 12:07:24 2010 New Revision: 327 Log: adapted the "mark-as-deleted" functions of the UI to the latest update of the backend; fixed a bug in "json_tmcl_validation" when iterating marked-as-deleted assocations; fixed a bug in the UI that appeared after committing delete-messages to the backend --> ticket #74 Modified: trunk/src/ajax/javascripts/datamodel.js trunk/src/ajax/javascripts/requests.js trunk/src/json/json_tmcl_validation.lisp trunk/src/model/datamodel.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Thu Oct 14 12:07:24 2010 @@ -4355,58 +4355,69 @@ if(type !== "Occurrence" && type !== "Name" && type !== "Variant" && type !== "Topic" && type !== "Association"){ throw "From makeRemoveObject(): type must be: \"Occurrence\" || \"Name\" " + - "|| \"Variant\" || \"Topic\" || \"Association\" but is " + type; + "|| \"Topic\" but is " + type; } if (!objectToDelete){ throw "From makeRemoveObject(): objectToDelete must be set"; } - var parentTopic = "null"; - if(type === "Occurrence" || type === "Name"){ - var psiFrame = objectToDelete.getFrame().parentNode.parentNode.parentNode.parentNode.select("tr." + CLASSES.subjectIdentifierFrame())[0]; + // --- Returns a JSON-object that corresponds to a topicStub + function makeJsonTopicStub(topicFrame){ + var topPSIs = "null"; + var psiFrame = topicFrame.select("tr." + CLASSES.subjectIdentifierFrame())[0]; var psiFields = psiFrame.select("input"); - for(i = 0; psiFields && i !== psiFields.length; ++i){ + for(var i = 0; psiFields && i !== psiFields.length; ++i){ var psiValue = psiFields[i].value; if(psiValue.strip().length !== 0){ - parentTopic = psiValue.strip().toJSON(); + topPSIs = new Array(psiValue.strip()).toJSON(); break; } } - } - - var topics = "null"; - if (type === "Topic"){ - var psiFrame = objectToDelete.getFrame().select("tr." + CLASSES.subjectIdentifierFrame())[0]; - var psiFields = psiFrame.select("input"); - for(i = 0; psiFields && i !== psiFields.length; ++i){ - var psiValue = psiFields[i].value; - if(psiValue.strip().length !== 0){ - topics = new Array(psiValue.strip()).toJSON(); + var topIIs = "null"; + var iiFrame = topicFrame.select("tr." + CLASSES.itemIdentityFrame())[0]; + var iiFields = iiFrame.select("input"); + for(var i = 0; iiFields && i !== iiFields.length; ++i){ + var iiValue = iiFields[i].value; + if(iiValue.strip().length !== 0){ + topIIs = new Array(iiValue.strip()).toJSON(); break; } } + var topSLs = "null"; + var slFrame = topicFrame.select("tr." + CLASSES.subjectLocatorFrame())[0]; + var slFields = slFrame.select("input"); + for(var i = 0; slFields && i !== slFields.length; ++i){ + var slValue = slFields[i].value; + if(slValue.strip().length !== 0){ + topSLs = new Array(slValue.strip()).toJSON(); + break; + } + } + return "{\"id\":\"null\",\"itemIdentities\":" + topIIs + + ",\"subjectLocators\":" + topSLs + ",\"subjectIdentifiers\":" + topPSIs + + ",\"instanceOfs\":\"null\",\"names\":\"null\",\"occurrences\":\"null\"}"; } - var deletedObjects = null; - if(type === "Topic"){ deletedObjects = topics; } - else { deletedObjects = "[" + objectToDelete.toJSON() + "]"; } + var delMessage = "null"; - var jsonData = "{\"type\":\"" + type + "\"," + - "\"topics\":" + topics + "," + - "\"associations\":" + "null" + "," + - "\"parentTopic\":" + parentTopic + "," + - "\"parentName\":" + "null" + "," + - "\"names\":" + (type === "Name" ? deletedObjects : "null") + "," + - "\"variants\":" + "null" + "," + - "\"occurrences\":" + (type === "Occurrence" ? deletedObjects : "null") + "," + - "\"parentAssociation\":" + "null" + "," + - "\"roles\":" + "null" + "}"; + switch(type){ + case "Topic": + delMessage = "{\"type\":\"Topic\",\"delete\":" + makeJsonTopicStub(objectToDelete.getFrame()) + "}"; + break; + case "Name": + case "Occurrence": + delMessage = "{\"type\":\"" + type + "\",\"parent\":" + + makeJsonTopicStub(objectToDelete.getFrame().parentNode.parentNode.parentNode.parentNode) + + ",\"delete\":" + objectToDelete.toJSON() + "}"; + break; + } - commitDeletedObject(jsonData, function(xhr){ + commitDeletedObject(delMessage, function(xhr){ alert("Objected deleted"); if(type === "Topic"){ $(CLASSES.subPage()).update(); - makeHome(); + setNaviClasses($(PAGES.home)); + makePage(PAGES.home, ""); } else if (type === "Occurrence" || type === "Name"){ if(objectToDelete.__owner__.__frames__.length > objectToDelete.__max__ Modified: trunk/src/ajax/javascripts/requests.js ============================================================================== --- trunk/src/ajax/javascripts/requests.js (original) +++ trunk/src/ajax/javascripts/requests.js Thu Oct 14 12:07:24 2010 @@ -219,7 +219,7 @@ } -// --- Sends a POST-Message to the server. The sent message enables the server +// --- Sends a DELETE-Message to the server. The sent message enables the server // --- to find the spcified object and mark it as deleted function commitDeletedObject(json, onSuccessHandler, onFailureHandler) { @@ -227,9 +227,8 @@ try{ var onFailure = onFailureHandler ? onFailureHandler : defaultFailureHandler; var timeFun = setAjaxTimeout(TIMEOUT, COMMIT_URL); - new Ajax.Request(MARK_AS_DELETED_URL, { - "method" : "post", + "method" : "delete", "postBody" : json, "onSuccess" : createXHRHandler(onSuccessHandler, timeFun), "onFailure" : createXHRHandler(onFailure, timeFun)}); Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Thu Oct 14 12:07:24 2010 @@ -202,7 +202,8 @@ (type (get-item-by-psi *type-psi* :revision revision))) (let ((topic-types (loop for role in (player-in-roles topic-instance :revision revision) - when (eq instance (instance-of role :revision revision)) + when (and (eq instance (instance-of role :revision revision)) + (parent role :revision revision)) collect (loop for other-role in (roles (parent role :revision revision) :revision revision) when (and (not (eq role other-role)) @@ -228,7 +229,8 @@ (type (get-item-by-psi *type-psi* :revision revision))) (let ((topic-instances (loop for role in (player-in-roles topic-instance :revision revision) - when (eq type (instance-of role :revision revision)) + when (and (eql type (instance-of role :revision revision)) + (parent role :revision revision)) collect (loop for other-role in (roles (parent role :revision revision) :revision revision) when (and (not (eq role other-role)) @@ -254,7 +256,8 @@ (subtype (get-item-by-psi *subtype-psi* :revision revision))) (let ((supertypes (loop for role in (player-in-roles topic-instance :revision revision) - when (eq subtype (instance-of role :revision revision)) + when (and (eq subtype (instance-of role :revision revision)) + (parent role :revision revision)) append (loop for other-role in (roles (parent role :revision revision) :revision revision) when (and (not (eq role other-role)) @@ -281,7 +284,8 @@ (subtype (get-item-by-psi *subtype-psi* :revision revision))) (let ((subtypes (loop for role in (player-in-roles topic-instance :revision revision) - when (eq supertype (instance-of role :revision revision)) + when (and (eq supertype (instance-of role :revision revision)) + (parent role :revision revision)) append (loop for other-role in (roles (parent role :revision revision) :revision revision) when (and (not (eq role other-role)) @@ -318,7 +322,8 @@ :revision revision)) (current-valid-subtypes (append valid-subtypes (list topic-instance)))) (loop for role in (player-in-roles topic-instance :revision revision) - when (and (eq supertype (instance-of role :revision revision)) + when (and (parent role :revision revision) + (eq supertype (instance-of role :revision revision)) (eq supertype-subtype (instance-of (parent role :revision revision) :revision revision))) @@ -357,7 +362,8 @@ (loop for subtype-of-this in all-subtypes-of-this append (loop for role in (player-in-roles subtype-of-this :revision revision) - when (and (eq type (instance-of role :revision revision)) + when (and (parent role :revision revision) + (eq type (instance-of role :revision revision)) (eq type-instance (instance-of (parent role :revision revision) :revision revision))) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Thu Oct 14 12:07:24 2010 @@ -2770,6 +2770,8 @@ (declare (ignorable source-locator)) (let ((owner (parent construct :revision 0))) (when owner + ;(private-delete-player construct (player construct :revision revision) + ;:revision revision) (private-delete-role owner construct :revision revision)))) 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 Thu Oct 14 12:07:24 2010 @@ -387,7 +387,8 @@ "Marks the corresponding elem as deleted." (declare (ignorable param)) ;param is currently not used (let ((http-method (hunchentoot:request-method*))) - (if (eq http-method :DELETE) + (if (or (eq http-method :DELETE) + (eq http-method :Post)) ;not nice - but the current ui-library can't send http-delete messages (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) (handler-case

1 0

[isidorus-cvs] r326 - in trunk: docs src src/json src/rest_interface src/unit_tests
by Lukas Giessmann 14 Oct '10

14 Oct '10

Author: lgiessmann Date: Wed Oct 13 18:27:38 2010 New Revision: 326 Log: added a mark-as-deleted handler to the RESTful interface, so PSIs, ItemIdentifiers, SubjectLocators, Topics, Names, Variants, Occurrences, Associations and Roles can be deleted by this backend-handler; added the corresponding unit-tests Added: trunk/src/json/json_delete_interface.lisp Modified: trunk/docs/xtm_json.txt trunk/src/isidorus.asd trunk/src/json/json_tmcl_validation.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/json_test.lisp Modified: trunk/docs/xtm_json.txt ============================================================================== --- trunk/docs/xtm_json.txt (original) +++ trunk/docs/xtm_json.txt Wed Oct 13 18:27:38 2010 @@ -449,29 +449,70 @@ //+----------------------------------------------------------------------------- //+ *Part 4: Object notation for marking objects as deleted -//+ type: the type of the deleted object, e.g. Topic for TopicC -//+ topics: a list of PSIs, where every single PSI represents a topic that -//+ has to be deleted -//+ associations: a list of associations that have to be deleted -//+ parent-topic: a single PSI of the name's, occurrence's or variant's owner -//+ topic -//+ parent-name: the parent name of the variants that have to be deleted -//+ (in this case the parent-topic is the topic of the name) -//+ names: a list of the deletable names -//+ variants: a list of deletable names -//+ occurrences: a list of the deletable occurrences -//+ parent-association: the parent association of the deletable roles -//+ roles: a list of the deltable roles +//+ *Topic +//+ *PSI +//+ *ItemIdentifier +//+ *SubjectLocator +//+ *Name +//+ *Variant +//+ *Occurrence +//+ *Association +//+ *Role //+----------------------------------------------------------------------------- +Topic: { - "type":<"Topic" | "Occurrence" | "Name" | "Association" | "Role" | "Variant" >, - "topics": [<psi-top-1>, <psi-top-2>, <...>], - "associations": [<association-1>, <association-2>, <...>], - "parentTopic": "topic-psi", - "parentName": <name>, - "names": [<name-1>, <name-2>, <...>], - "variants": [<variant-1>, <variant-2>, <...>], - "occurrences": [<occurrence-1>, <occurrence-2>, <...>], - "parentAssociation": <association>, - "roles": [<role-1>, <role-2>, <...>] + \"type\":\"Topic\", + \"delete\":<topic> //only the topic's identifiers are evaluated +} + +PSI: +{ + \"type\":\"PSI\", + \"delete\":\"PSI-value\" +} + +Item-Identifier: +{ + \"type\":\"ItemIdentity\", + \"delete\":\"ItemIdentity-value\" +} + +Subject-Locator: +{ + \"type\":SubjectLocator\", + \"delete\":\"SubjectLocator-value\" +} + +Name: +{ + \"type\":\"Name\", + \"parent\":<Topic>, // the topic-identifiers are enough + \"delete\":<Name> +} + +Variant: +{ + \"type\":\"Variant\", + \"parent\":<Name>, // the full name that is needed for TMDM equality + \"parentOfParent\":<Topic>, // the topic-identifiers are enough + \"delete\" +} + +Occurrence: +{ + \"type\":\"Occurrence\", // the full occurrence that is neede for full TMDM equality + \"parent\":<Topic>, // the topic-identifiers are enough + \"delete\":<Occurrence> +} + +Association: +{ \"type\":\"Association\", + \"delete\":<Association> // the full association that is neede for full TMDM equality +} + +Role: +{ + \"type\":\"Role\", + \"parent\":<Association>, // the full association that is neede for full TMDM equality + \"delete\":<Role> // the full role that is neede for full TMDM equality } Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Oct 13 18:27:38 2010 @@ -165,10 +165,12 @@ :depends-on ("json_tmcl_constants")) (:file "json_importer") (:file "json_tmcl_validation" - :depends-on ("json_tmcl_constants" "json_exporter" )) + :depends-on ("json_tmcl_constants" "json_exporter" "json_importer")) (:file "json_tmcl_constants") (:file "json_tmcl" - :depends-on ("json_tmcl_validation" "json_importer"))) + :depends-on ("json_tmcl_validation" "json_importer")) + (:file "json_delete_interface" + :depends-on ("json_importer"))) :depends-on ("model" "xml")) (:module "ajax" Added: trunk/src/json/json_delete_interface.lisp ============================================================================== --- (empty file) +++ trunk/src/json/json_delete_interface.lisp Wed Oct 13 18:27:38 2010 @@ -0,0 +1,356 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(defpackage :json-delete-interface + (:use :cl :datamodel :json-importer) + (:export :mark-as-deleted-from-json)) + +(in-package :json-delete-interface) + + +(defun mark-as-deleted-from-json (json-data &key (revision *TM-REVISION*)) + "Marks an object that is specified by the given JSON data as deleted." + (declare (string json-data) (integer revision)) + (let ((json-list (json:decode-json-from-string json-data))) + (let ((type nil) + (parent nil) + (parent-of-parent nil) + (delete nil)) + (loop for json-entry in json-list + do (let ((st (car json-entry)) + (nd (cdr json-entry))) + (cond ((eql st :type) + (setf type nd)) + ((eql st :delete) + (setf delete nd)) + ((eql st :parent) + (setf parent nd)) + ((eql st :parent-of-parent) + (setf parent-of-parent nd))))) + (cond ((string= type "Topic") + (delete-topic-from-json delete :revision revision)) + ((string= type "PSI") + (delete-identifier-from-json delete 'd:PersistentIdC + #'d:delete-psi :revision revision)) + ((string= type "ItemIdentity") + (delete-identifier-from-json delete 'd:ItemIdentifierC + #'d:delete-item-identifier + :revision revision)) + ((string= type "SubjectLocator") + (delete-identifier-from-json delete 'd:SubjectLocatorC + #'d:delete-locator :revision revision)) + ((string= type "Name") + (delete-name-from-json + delete (find-parent parent :revision revision) :revision revision)) + ((string= type "Variant") + (let ((parent-top (find-parent parent-of-parent :revision revision))) + (delete-variant-from-json + delete (find-parent parent :parent-of-parent parent-top + :revision revision) :revision revision))) + ((string= type "Occurrence") + (delete-occurrence-from-json + delete (find-parent parent :revision revision) :revision revision)) + ((string= type "Association") + (delete-association-from-json delete :revision revision)) + ((string= type "Role") + (delete-role-from-json delete (find-parent parent :revision revision))) + (t + (error "Type \"~a\" is not defined" type)))))) + + +(defun delete-role-from-json (json-decoded-list parent-assoc + &key (revision *TM-REVISION*)) + "Deletes the passed role object and returns t otherwise this + function returns nil." + (declare (list json-decoded-list) (integer revision)) + (let ((j-role (make-role-plist json-decoded-list))) + (when parent-assoc + (let ((role-to-delete + (loop for role in (d:roles parent-assoc :revision revision) + when (and + (eql + (d:instance-of role :revision revision) + (getf j-role :type)) + (eql + (d:player role :revision revision) + (getf j-role :topicRef))) + return role))) + (when role-to-delete + (d:delete-role parent-assoc role-to-delete :revision revision) + t))))) + + +(defun delete-association-from-json (json-decoded-list &key + (revision *TM-REVISION*)) + "Deletes the passed association object and returns t otherwise this + function returns nil." + (declare (list json-decoded-list) (integer revision)) + (let ((assoc (find-association json-decoded-list :revision revision))) + (when assoc + (d:mark-as-deleted assoc :revision revision :source-locator nil) + t))) + + +(defun make-role-plist (json-decoded-list &key (revision *TM-REVISION*)) + "Returns a plist that represents a list of association roles + of the passed json-decoded-list." + (declare (list json-decoded-list) (integer revision)) + (let ((type nil) + (player nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :topic-Ref) + (setf player + (json-importer::psis-to-topic nd :revision revision))) + ((eql st :type) + (setf type + (json-importer::psis-to-topic nd :revision revision)))))) + (list :type type :topicRef player))) + + +(defun find-association (json-decoded-list &key (revision *TM-REVISION*)) + "Returns an association object." + (declare (list json-decoded-list) (integer revision)) + (let ((j-roles nil) + (type nil) + (scopes nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :roles) + (setf j-roles + (map 'list #'(lambda(j-role) + (make-role-plist j-role :revision revision)) + nd))) + ((eql st :type) + (setf type (json-importer::psis-to-topic nd :revision revision))) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision)))))) + (loop for assoc in (d:get-all-associations revision) + when (and + (not + (set-exclusive-or + (d:roles assoc :revision revision) + j-roles + :test #'(lambda(a-role j-role) + (and (eql (d:instance-of a-role :revision revision) + (getf j-role :type)) + (eql (d:player a-role :revision revision) + (getf j-role :topicRef)))))) + (eql type (d:instance-of assoc :revision revision)) + (not (set-exclusive-or scopes (d:themes assoc :revision revision)))) + return assoc))) + + +(defun find-parent (parent &key (parent-of-parent nil) + (revision *TM-REVISION*)) + "Returns the construct (Topic|Name|Association) corresponding to the + passed parameters." + (declare (list parent) (integer revision) + (type (or TopicC null) parent-of-parent)) + (let ((value nil) + (scopes nil) + (type nil) + (j-roles nil)) + (loop for j-entry in parent + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :value) + (setf value nd)) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision))) + ((eql st :type) + (setf type (json-importer::psis-to-topic nd :revision revision))) + ((eql st :roles) + (setf j-roles nd))))) + (cond (parent-of-parent + (loop for name in (d:names parent-of-parent :revision revision) + when (and (string= value (d:charvalue name)) + (eql type (d:instance-of name :revision revision)) + (not (set-exclusive-or scopes + (d:themes name :revision revision)))) + return name)) + (j-roles ;must be an association + (find-association parent :revision revision)) + (t ;must be a topic + (find-topic-from-json-identifiers + parent :revision revision))))) + + +(defun delete-variant-from-json (json-decoded-list parent-name + &key (revision *TM-REVISION*)) + "Deletes the passed variant from the given name and returns t if the + operation succeeded." + (declare (list json-decoded-list) (integer revision) + (type (or NameC null))) + (when parent-name + (let ((varvalue nil) + (vardatatype constants::*xml-uri*) + (scopes nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :resource-ref) + (setf varvalue nd)) + ((eql st :resource-data) + (loop for j-dt in nd + do (let ((dt-st (car j-dt)) + (dt-nd (cdr j-dt))) + (cond ((eql dt-st :datatype) + (setf vardatatype dt-nd)) + ((eql dt-st :value) + (setf varvalue dt-nd)))))) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision)))))) + (let ((var-to-delete + (loop for var in (d:variants parent-name :revision revision) + when (and (string= varvalue (d:charvalue var)) + (string= vardatatype (d:datatype var)) + (not (set-exclusive-or + scopes (d:themes var :revision revision)))) + return var))) (when var-to-delete + (delete-variant parent-name var-to-delete :revision revision) + t))))) + + +(defun delete-occurrence-from-json (json-decoded-list parent-top + &key (revision *TM-REVISION*)) + "Deletes the passed occurrence from the given topic and returns t if the + operation succeeded." + (declare (list json-decoded-list) (integer revision)) + (when parent-top + (let ((occvalue nil) + (occdatatype constants::*xml-uri*) + (scopes nil) + (type nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :resource-ref) + (setf occvalue nd)) + ((eql st :resource-data) + (loop for j-dt in nd + do (let ((dt-st (car j-dt)) + (dt-nd (cdr j-dt))) + (cond ((eql dt-st :datatype) + (setf occdatatype dt-nd)) + ((eql dt-st :value) + (setf occvalue dt-nd)))))) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision))) + ((eql st :type) + (setf type (json-importer::psis-to-topic + nd :revision revision)))))) + (let ((occ-to-delete + (loop for occ in (d:occurrences parent-top :revision revision) + when (and (string= occvalue (d:charvalue occ)) + (string= occdatatype (d:datatype occ)) + (eql type (d:instance-of occ :revision revision)) + (not (set-exclusive-or + scopes (d:themes occ :revision revision)))) + return occ))) + (when occ-to-delete + (delete-occurrence parent-top occ-to-delete :revision revision) + t))))) + + +(defun delete-name-from-json (json-decoded-list parent-top + &key (revision *TM-REVISION*)) + (declare (list json-decoded-list) (integer revision)) + (when parent-top + (let ((namevalue nil) + (scopes nil) + (type nil)) + (loop for j-entry in json-decoded-list + do (let ((st (car j-entry)) + (nd (cdr j-entry))) + (cond ((eql st :value) + (setf namevalue nd)) + ((eql st :scopes) + (setf scopes (json-importer::json-to-scope nd revision))) + ((eql st :type) + (setf type (json-importer::psis-to-topic + nd :revision revision)))))) + (let ((name-to-delete + (loop for name in (names parent-top :revision revision) + when (and (string= namevalue (d:charvalue name)) + (eql type (d:instance-of name :revision revision)) + (not (set-exclusive-or + scopes (d:themes name :revision revision)))) + return name))) + (when name-to-delete + (delete-name parent-top name-to-delete :revision revision) + t))))) + + +(defun delete-identifier-from-json (uri class delete-function + &key (revision *TM-REVISION*)) + "Deleted the passed identifier of the construct it is associated with. + Returns t if there was deleted an item otherweise it returns nil." + (declare (string uri) (integer revision) (symbol class)) + (let ((id (elephant:get-instance-by-value + class 'd:uri uri))) + (if (and id (typep id class)) + (progn + (apply delete-function + (list (d:identified-construct id :revision revision) + id :revision revision)) + t) + nil))) + + +(defun delete-topic-from-json (json-decoded-list &key (revision *TM-REVISION*)) + "Searches for a topic corresponding to the given identifiers. + Returns t if there was deleted an item otherweise it returns nil." + (declare (list json-decoded-list) (integer revision)) + (let ((top-to-delete (find-topic-from-json-identifiers + json-decoded-list :revision revision))) + (when top-to-delete + (mark-as-deleted top-to-delete :source-locator nil :revision revision) + t))) + + +(defun get-ids-from-json (json-decoded-list) + "Returns all id uri formatted as plist generated from the json-list." + (let ((iis nil) + (psis nil) + (sls nil)) + (loop for json-entry in json-decoded-list + do (let ((st (car json-entry)) + (nd (cdr json-entry))) + (cond ((eql st :item-identities) + (setf iis nd)) + ((eql st :subject-locators) + (setf sls nd)) + ((eql st :subject-identifiers) + (setf psis nd))))) + (list :subjectIdentifiers psis + :itemIdentities iis + :subjectLocators sls))) + + +(defun find-topic-from-json-identifiers (json-decoded-list + &key (revision *TM-REVISION*)) + "Returns a topic corresponding to the passed identifiers." + (declare (list json-decoded-list) (integer revision)) + (let ((ids (get-ids-from-json json-decoded-list))) + (let ((identifier + (if (getf ids :itemIdentities) + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri (first (getf ids :itemIdentities))) + (if (getf ids :subjectIdentifiers) + (elephant:get-instance-by-value + 'd:PersistentIdC 'd:uri (first (getf ids :subjectIdentifiers))) + (when (getf ids :subjectLocators) + (elephant:get-instance-by-value + 'd:SubjectLocatorC 'd:uri + (first (getf ids :subjectLocators)))))))) + (when identifier + (d:identified-construct identifier :revision revision))))) \ No newline at end of file Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Wed Oct 13 18:27:38 2010 @@ -8,7 +8,7 @@ (defpackage :json-tmcl - (:use :cl :datamodel :constants :json-tmcl-constants) + (:use :cl :datamodel :constants :json-tmcl-constants :json-importer) (:export :get-constraints-of-fragment :topictype-p :abstract-p 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 Wed Oct 13 18:27:38 2010 @@ -9,23 +9,46 @@ (in-package :rest-interface) -(defparameter *json-get-prefix* "/json/get/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> -(defparameter *get-rdf-prefix* "/json/get/rdf/(.+)$") ;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi> -(defparameter *json-commit-url* "/json/commit/?$") ;the url to commit a json fragment by "put" or "post" -(defparameter *json-get-all-psis* "/json/psis/?$") ;the url to get all topic psis of isidorus -> localhost:8000/json/psis -(defparameter *json-get-summary-url* "/json/summary/?$") ;the url to get a summary of all topic stored in isidorus; you have to set the GET-parameter "start" for the start index of all topics within elephant and the GET-paramter "end" for the last index of the topic sequence -> http://localhost:8000/json/summary/?start=12&end=13 -(defparameter *json-get-all-type-psis* "/json/tmcl/types/?$") ;returns a list of all psis that can be a type -(defparameter *json-get-all-instance-psis* "/json/tmcl/instances/?$") ;returns a list of all psis that belongs to a valid topic-instance -(defparameter *json-get-topic-stub-prefix* "/json/topicstubs/(.+)$") ;the json prefix for getting some topic stub information of a topic -(defparameter *json-get-type-tmcl-url* "/json/tmcl/type/?$") ;the json url for getting some tmcl information of a topic treated as a type -(defparameter *json-get-instance-tmcl-url* "/json/tmcl/instance/?$") ;the json url for getting some tmcl information of a topic treated as an instance -(defparameter *json-get-overview* "/json/tmcl/overview/?$") ; returns a json-object representing a tree view -(defparameter *ajax-user-interface-url* "/isidorus") ;the url to the user interface; -(defparameter *ajax-user-interface-css-prefix* "/css") ;the url to the css files of the user interface -(defparameter *ajax-user-interface-css-directory-path* "ajax/css") ;the directory contains the css files -(defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") ;the file path to the HTML file implements the user interface -(defparameter *ajax-javascript-directory-path* "ajax/javascripts") ;the directory which contains all necessary javascript files -(defparameter *ajax-javascript-url-prefix* "/javascripts") ; the url prefix of all javascript files +;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi> +(defparameter *json-get-prefix* "/json/get/(.+)$") +;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi> +(defparameter *get-rdf-prefix* "/json/get/rdf/(.+)$") +;the url to commit a json fragment by "put" or "post" +(defparameter *json-commit-url* "/json/commit/?$") +;the url to get all topic psis of isidorus -> localhost:8000/json/psis +(defparameter *json-get-all-psis* "/json/psis/?$") +;the url to get a summary of all topic stored in isidorus; you have to set the +;GET-parameter "start" for the start index of all topics within elephant and the +;GET-paramter "end" for the last index of the topic sequence +; -> http://localhost:8000/json/summary/?start=12&end=13 +(defparameter *json-get-summary-url* "/json/summary/?$") +;returns a list of all psis that can be a type +(defparameter *json-get-all-type-psis* "/json/tmcl/types/?$") +;returns a list of all psis that belongs to a valid topic-instance +(defparameter *json-get-all-instance-psis* "/json/tmcl/instances/?$") +;the json prefix for getting some topic stub information of a topic +(defparameter *json-get-topic-stub-prefix* "/json/topicstubs/(.+)$") +;the json url for getting some tmcl information of a topic treated as a type +(defparameter *json-get-type-tmcl-url* "/json/tmcl/type/?$") +;the json url for getting some tmcl information of a topic treated as an instance +(defparameter *json-get-instance-tmcl-url* "/json/tmcl/instance/?$") +;returns a json-object representing a tree view +(defparameter *json-get-overview* "/json/tmcl/overview/?$") +;the url to the user interface +(defparameter *ajax-user-interface-url* "/isidorus") +;the url to the css files of the user interface +(defparameter *ajax-user-interface-css-prefix* "/css") +;the directory contains the css files +(defparameter *ajax-user-interface-css-directory-path* "ajax/css") +;the file path to the HTML file implements the user interface +(defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") +;the directory which contains all necessary javascript files +(defparameter *ajax-javascript-directory-path* "ajax/javascripts") +;the url prefix of all javascript files +(defparameter *ajax-javascript-url-prefix* "/javascripts") +;the url suffix that calls the mark-as-deleted handler +(defparameter *mark-as-deleted-url* "/mark-as-deleted") + (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*) (get-rdf-prefix *get-rdf-prefix*) @@ -43,7 +66,8 @@ (ajax-user-interface-css-prefix *ajax-user-interface-css-prefix*) (ajax-user-interface-css-directory-path *ajax-user-interface-css-directory-path*) (ajax-javascripts-directory-path *ajax-javascript-directory-path*) - (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*)) + (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) + (mark-as-deleted-url *mark-as-deleted-url*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -111,6 +135,9 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-summary-url #'return-topic-summaries) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler) hunchentoot:*dispatch-table*)) ;; ============================================================================= @@ -356,6 +383,30 @@ (format nil "Condition: \"~a\"" err)))))) +(defun mark-as-deleted-handler (&optional param) + "Marks the corresponding elem as deleted." + (declare (ignorable param)) ;param is currently not used + (let ((http-method (hunchentoot:request-method*))) + (if (eq http-method :DELETE) + (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) + (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) + (handler-case + (with-writer-lock + (let ((result (json-delete-interface:mark-as-deleted-from-json + json-data :revision (d:get-revision)))) + (if result + (format nil "") ;operation succeeded + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) + (format nil "object not found"))))) + (condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; ============================================================================= Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Wed Oct 13 18:27:38 2010 @@ -13,9 +13,11 @@ :xml-importer :json-exporter :json-importer + :json-tmcl :datamodel :it.bese.FiveAM :unittests-constants + :json-delete-interface :fixtures) (:export :test-to-json-string-topics :test-to-json-string-associations @@ -37,7 +39,14 @@ :test-json-importer-merge-1 :test-json-importer-merge-2 :test-json-importer-merge-3 - :test-get-all-topic-psis)) + :test-get-all-topic-psis + :test-delete-from-json-identifiers + :test-delete-from-json-topic + :test-delete-from-json-name + :test-delete-from-json-occurrence + :test-delete-from-json-variant + :test-delete-from-json-association + :test-delete-from-json-role)) (in-package :json-test) @@ -1495,6 +1504,647 @@ (is-true (format t "found bad topic-psis: ~a" topic-psis))))))))) +(test test-delete-from-json-identifiers + "Tests the function delete-from-json with several identifiers." + (with-fixture with-empty-db ("data_base") + (let ((json-psi-1 "{\"type\":\"PSI\",\"delete\":\"psi-1-1\"}") + (json-psi-3 "{\"type\":\"PSI\",\"delete\":\"psi-1-3\"}") + (json-sl-1 "{\"type\":\"SubjectLocator\",\"delete\":\"sl-1-1\"}") + (json-sl-3 "{\"type\":\"SubjectLocator\",\"delete\":\"sl-1-3\"}") + (json-ii-1 "{\"type\":\"ItemIdentity\",\"delete\":\"ii-1-1\"}") + (json-ii-3 "{\"type\":\"ItemIdentity\",\"delete\":\"ii-1-3\"}") + (rev-1 100) + (rev-2 200)) + (let ((top (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1") + (make-construct 'PersistentIdC + :uri "psi-1-2")) + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1") + (make-construct 'SubjectLocatorC + :uri "sl-1-2")) + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-2")) + :names (list (make-construct + 'NameC + :charvalue "name" + :start-revision rev-1 + :item-identifiers (list (make-construct + 'ItemIdentifierC + :uri "ii-1-1"))))))) + (with-revision rev-2 + (is (eql top (find-item-by-revision top rev-1))) + (is-false (mark-as-deleted-from-json json-psi-3)) + (is-false (mark-as-deleted-from-json json-sl-3)) + (is-false (mark-as-deleted-from-json json-ii-3)) + (is (= (length (psis top)) 2)) + (is (= (length (locators top)) 2)) + (is (= (length (item-identifiers top)) 1)) + (is (= (length (names top)) 1)) + (is (= (length (item-identifiers (first (names top)))) 1)) + (is-true (mark-as-deleted-from-json json-psi-1)) + (is (= (length (psis top)) 1)) + (is (string= (uri (first (psis top))) "psi-1-2")) + (is-true (mark-as-deleted-from-json json-sl-1)) + (is (= (length (locators top)) 1)) + (is (string= (uri (first (locators top))) "sl-1-2")) + (is-true (mark-as-deleted-from-json json-ii-1)) + (is (= (length (item-identifiers top)) 1)) + (is (string= (uri (first (item-identifiers top))) "ii-1-2")) + (is (= (length (item-identifiers (first (names top)))) 0))) + (with-revision rev-1 + (is (= (length (psis top)) 2)) + (is (= (length (locators top)) 2)) + (is (= (length (item-identifiers top)) 1)) + (is (= (length (names top)) 1)) + (is (= (length (item-identifiers (first (names top)))) 1))))))) + + +(test test-delete-from-json-topic + "Tests the function delete-from-json with several identifiers." + (with-fixture with-empty-db ("data_base") + (let ((j-top-1 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (j-top-2 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"psi-1-1\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (j-top-3 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":[\"sl-1-1\"],\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (j-top-4 "{\"type\":\"Topic\",\"delete\":{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-2\"],\"subjectLocators\":[\"sl-1-2\"],\"subjectIdentifiers\":[\"psi-1-2\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null}}") + (rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")))) + (top-2 (make-construct + 'TopicC + :start-revision rev-2 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")))) + (top-3 (make-construct + 'TopicC + :start-revision rev-1 + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1")))) + (top-4 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-3")) + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-3")) + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-3"))))) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-1 top-2 top-3 top-4))) + (is-false (mark-as-deleted-from-json j-top-4 :revision rev-2)) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-1 top-2 top-3 top-4))) + (is-true (mark-as-deleted-from-json j-top-1 :revision rev-2)) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-2 top-3 top-4))) + (is-true (mark-as-deleted-from-json j-top-2 :revision rev-3)) + (is-false (set-exclusive-or (get-all-topics rev-3) + (list top-3 top-4))) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-2 top-3 top-4))) + (is-true (mark-as-deleted-from-json j-top-3 :revision rev-2)) + (is-false (set-exclusive-or (get-all-topics rev-3) + (list top-4))) + (is-false (set-exclusive-or (get-all-topics rev-2) + (list top-2 top-4))) + (is-false (set-exclusive-or (get-all-topics rev-3) + (list top-4))))))) + + +(test test-delete-from-json-name + (with-fixture with-empty-db ("data_base") + (let ((j-parent-1 "{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-parent-2 "{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"psi-1-1\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-type "{\"type\":\"Name\",\"parent\":") + (j-name-1 "\"delete\":{\"type\":[\"nType-1\"],\"scopes\":null,\"value\":\"name-1\"}}") + (j-name-2 "\"delete\":{\"type\":null,\"scopes\":[[\"nScope-1\"],[\"nScope-2\"]],\"value\":\"name-2\"}}") + (j-name-3 "\"delete\":{\"type\":null,\"scopes\":null,\"value\":\"name-3\"}}") + (rev-1 100) + (rev-2 200)) + (let ((nType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nType-1")))) + (nScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nScope-1")))) + (nScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nScope-2"))))) + (let ((j-req-1 (concatenate 'string j-type j-parent-1 j-name-1)) + (j-req-2 (concatenate 'string j-type j-parent-1 j-name-2)) + (j-req-3 (concatenate 'string j-type j-parent-1 j-name-3)) + (j-req-4 (concatenate 'string j-type j-parent-2 j-name-1)) + (j-req-5 (concatenate 'string j-type j-parent-2 j-name-2)) + (top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")) + :names (list (make-construct 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1") + (make-construct 'NameC + :start-revision rev-1 + :themes (list nScope-1 nScope-2) + :charvalue "name-2") + (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3")))) + (top-2 (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")) + :names (list (make-construct 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1") + (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3")))) + (top-3 (make-construct + 'TopicC + :start-revision rev-1 + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1")) + :names (list (make-construct 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1") + (make-construct 'NameC + :start-revision rev-1 + :themes (list nScope-1 nScope-2) + :charvalue "name-2") + (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3"))))) + (with-revision rev-2 + (is (= (length (get-all-topics)) 6)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 8)) + (is (= (length (names top-1)) 3)) + (is (= (length (names top-2)) 2)) + (is (= (length (names top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-1)) + (list "name-2" "name-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-1)) + (list "name-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (names top-1)) + (is-false (mark-as-deleted-from-json j-req-3)) + (is-false (names top-1)) + (is (= (length (names top-2)) 2)) + (is (= (length (names top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-4)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-2)) + (list "name-3") :test #'string=)) + (is-false (mark-as-deleted-from-json j-req-5)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (names top-2)) + (list "name-3") :test #'string=)) + (is (= (length (names top-3)) 3)))))))) + + +(test test-delete-from-json-occurrence + (with-fixture with-empty-db ("data_base") + (let ((j-parent-1 "{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-parent-2 "{\"id\":\"any-id\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"psi-1-1\"],\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-type "{\"type\":\"Occurrence\",\"parent\":") + (j-occ-1 "\"delete\":{\"type\":[\"oType-1\"],\"scopes\":null,\"resourceRef\":\"value-1\"}}") + (j-occ-2 "\"delete\":{\"type\":[\"oType-2\"],\"scopes\":[[\"oScope-1\"],[\"oScope-2\"]],\"resourceData\":{\"datatype\":\"datatype-1\",\"value\":\"value-2\"}}}") + (j-occ-3 "\"delete\":{\"type\":[\"oType-1\"],\"scopes\":null,\"resourceData\":{\"datatype\":\"datatype-2\",\"value\":\"value-3\"}}}") + (rev-1 100) + (rev-2 200)) + (let ((oType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oType-1")))) + (oType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oType-2")))) + (oScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oScope-1")))) + (oScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "oScope-2"))))) + (let ((j-req-1 (concatenate 'string j-type j-parent-1 j-occ-1)) + (j-req-2 (concatenate 'string j-type j-parent-1 j-occ-2)) + (j-req-3 (concatenate 'string j-type j-parent-1 j-occ-3)) + (j-req-4 (concatenate 'string j-type j-parent-2 j-occ-1)) + (j-req-5 (concatenate 'string j-type j-parent-2 j-occ-2)) + (top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")) + :occurrences + (list (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-1" + :datatype constants::*xml-uri*) + (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-2 + :themes (list oScope-1 oScope-2) + :charvalue "value-2" + :datatype "datatype-1") + (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-3" + :datatype "datatype-2")))) + (top-2 (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")) + :occurrences + (list (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-1" + :datatype constants::*xml-uri*) + (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "value-3" + :datatype "datatype-2")))) + (top-3 (make-construct + 'TopicC + :start-revision rev-1 + :locators (list (make-construct 'SubjectLocatorC + :uri "sl-1-1")) + :occurrences + (list (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of oType-1 + :charvalue "value-1" + :datatype constants::*xml-uri*) + (make-construct 'OccurrenceC + :start-revision rev-1 + :themes (list oScope-1 oScope-2) + :charvalue "value-2" + :datatype "datatype-1") + (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "value-3" + :datatype "datatype-2"))))) + (with-revision rev-2 + (is (= (length (get-all-topics)) 7)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 8)) + (is (= (length (occurrences top-1)) 3)) + (is (= (length (occurrences top-2)) 2)) + (is (= (length (occurrences top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-1)) + (list "value-2" "value-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-1)) + (list "value-3") :test #'string=)) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (occurrences top-1)) + (is (= (length (occurrences top-2)) 2)) + (is (= (length (occurrences top-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-4)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-2)) + (list "value-3") :test #'string=)) + (is-false (mark-as-deleted-from-json j-req-5)) + (is-false (set-exclusive-or (map 'list #'d:charvalue + (occurrences top-2)) + (list "value-3") :test #'string=)) + (is (= (length (occurrences top-3)) 3)))))))) + + +(test test-delete-from-json-variant + (with-fixture with-empty-db ("data_base") + (let ((j-parent-of-parent-1 "\"parentOfParent\":{\"id\":\"any-id\",\"itemIdentities\":[\"ii-1-1\"],\"subjectLocators\":null,\"subjectIdentifiers\":null,\"instanceOfs\":null,\"names\":null,\"occurrence\":null},") + (j-type "{\"type\":\"Variant\",") + (j-parent-1 "\"parent\":{\"type\":[\"nType-1\"],\"scopes\":null,\"value\":\"name-1\"},") + (j-parent-2 "\"parent\":{\"type\":null,\"scopes\":[[\"vScope-1\"],[\"vScope-2\"]],\"value\":\"name-2\"},") + (j-var-1 "\"delete\":{\"scopes\":[[\"vScope-1\"]],\"resourceRef\":\"value-1\"}}") + (j-var-2 "\"delete\":{\"scopes\":[[\"vScope-1\"],[\"vScope-2\"]],\"resourceData\":{\"datatype\":\"datatype-1\",\"value\":\"value-2\"}}}") + (rev-1 100) + (rev-2 200)) + (let ((nType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "nType-1")))) + (vScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "vScope-1")))) + (vScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "vScope-2"))))) + (let ((j-req-1 (concatenate 'string j-type j-parent-of-parent-1 + j-parent-1 j-var-1)) + (j-req-2 (concatenate 'string j-type j-parent-of-parent-1 + j-parent-1 j-var-2)) + (j-req-3 (concatenate 'string j-type j-parent-of-parent-1 + j-parent-2 j-var-1)) + (top-1 (make-construct + 'TopicC + :start-revision rev-1 + :item-identifiers (list (make-construct 'ItemIdentifierC + :uri "ii-1-1")) + :names (list (make-construct + 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1" + :variants (list (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1) + :datatype constants::*xml-uri* + :charvalue "value-1") + (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :datatype "datatype-1" + :charvalue "value-2") + (make-construct + 'VariantC + :start-revision rev-1 + :datatype "datatpye-1" + :charvalue "value-2"))) + (make-construct 'NameC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :charvalue "name-2" + :variants (list (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1) + :datatype constants::*xml-uri* + :charvalue "value-1") + (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :datatype "datatype-1" + :charvalue "value-2") + (make-construct + 'VariantC + :start-revision rev-1 + :datatype "datatpye-1" + :charvalue "value-2")))))) + (top-2 (make-construct + 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "psi-1-1")) + :names (list (make-construct + 'NameC + :start-revision rev-1 + :instance-of nType-1 + :charvalue "name-1" + :variants (list (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1) + :datatype constants::*xml-uri* + :charavalue "value-1") + (make-construct + 'VariantC + :start-revision rev-1 + :themes (list vScope-1 vScope-2) + :datatype "datatype-1" + :charvalue "value-2") + (make-construct + 'VariantC + :start-revision rev-1 + :datatype "datatpye-1" + :charvalue "value-2"))))))) + (with-revision rev-2 + (is (= (length (get-all-topics)) 5)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 9)) + (let ((name-1 (find "name-1" (names top-1) :key #'charvalue + :test #'string=)) + (name-2 (find "name-2" (names top-1) :key #'charvalue + :test #'string=)) + (name-3 (first (names top-2)))) + (is-true name-1) + (is-true name-2) + (is-true name-3) + (is (= (length (variants name-1)) 3)) + (is (= (length (variants name-2)) 3)) + (is (= (length (variants name-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (variants name-1)) + (list "value-2" "value-2") :test #'string=)) + (is (= (length (variants name-1)) 2)) + (is (= (length (variants name-2)) 3)) + (is (= (length (variants name-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (variants name-1)) + (list "value-2" ) :test #'string=)) + (is (= (length (variants name-1)) 1)) + (is (= (length (variants name-2)) 3)) + (is (= (length (variants name-3)) 3)) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (set-exclusive-or (map 'list #'d:charvalue (variants name-2)) + (list "value-2" ) :test #'string=)) + (is (= (length (variants name-1)) 1)) + (is (= (length (variants name-2)) 2)) + (is (= (length (variants name-3)) 3))))))))) + + +(test test-delete-from-json-association + (with-fixture with-empty-db ("data_base") + (let ((j-type "{\"type\":\"Association\",") + (j-role-1 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-1\"]}") + (j-role-2 "{\"type\":[\"rType-2\"],\"topicRef\":[\"player-1\"]}") + (j-role-3 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-2\"]}") + (rev-1 100) + (rev-2 200)) + (let ((j-req-1 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) + (j-req-2 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) + (j-req-3 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]}}")) + (aType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-1")))) + (aType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-2")))) + (aScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-1")))) + (aScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-2")))) + (player-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-1")))) + (player-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-2")))) + (rType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-1")))) + (rType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-2"))))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of rType-1)) + (role-2 (list :start-revision rev-1 + :player player-1 + :instance-of rType-2)) + (role-3 (list :start-revision rev-1 + :player player-2 + :instance-of rType-1))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-1 + :themes (list aScope-1) + :roles (list role-1 role-2))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-2 + :themes (list aScope-1 aScope-2) + :roles (list role-1 role-2))) + (assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-1 + :roles (list role-1 role-2 role-3)))) + (with-revision rev-2 + (is (= (length (get-all-associations)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-true (marked-as-deleted-p assoc-1)) + (is-false (set-exclusive-or (get-all-associations) + (list assoc-2 assoc-3))) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or (get-all-associations) + (list assoc-3))) + (is-true (mark-as-deleted-from-json j-req-3)) + (is-false (get-all-associations))))))))) + + +(test test-delete-from-json-role + (with-fixture with-empty-db ("data_base") + (let ((j-type "{\"type\":\"Role\",") + (j-role-1 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-1\"]}") + (j-role-2 "{\"type\":[\"rType-2\"],\"topicRef\":[\"player-1\"]}") + (j-role-3 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-2\"]}") + (rev-1 100) + (rev-2 200)) + (let ((j-req-1 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3"]},\"delete\":" j-role-1 "}")) + (j-req-2 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-1 "}")) + (j-req-3 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-2 "}")) + (aType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-1")))) + (aType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aType-2")))) + (aScope-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-1")))) + (aScope-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "aScope-2")))) + (player-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-1")))) + (player-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "player-2")))) + (rType-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-1")))) + (rType-2 (make-construct 'TopicC + :start-revision rev-1 + :psis (list (make-construct 'PersistentIdC + :uri "rType-2"))))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of rType-1)) + (role-2 (list :start-revision rev-1 + :player player-1 + :instance-of rType-2)) + (role-3 (list :start-revision rev-1 + :player player-2 + :instance-of rType-1))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-1 + :themes (list aScope-1) + :roles (list role-1 role-2 role-3))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of aType-2 + :themes (list aScope-1 aScope-2) + :roles (list role-1 role-2 role-3)))) + (with-revision rev-2 + (is (= (length (get-all-associations)) 2)) + (is (= (length (roles assoc-1)) 3)) + (is (= (length (roles assoc-2)) 3)) + (is-true (mark-as-deleted-from-json j-req-1)) + (is-false (set-exclusive-or + (roles assoc-1) + (list role-2 role-3) + :test #'(lambda(a-role j-role) + (and (eql (instance-of a-role) + (getf j-role :instance-of)) + (eql (player a-role) + (getf j-role :player)))))) + (is (= (length (roles assoc-1)) 2)) + (is (= (length (roles assoc-2)) 3)) + (is-true (mark-as-deleted-from-json j-req-2)) + (is-false (set-exclusive-or + (roles assoc-2) + (list role-2 role-3) + :test #'(lambda(a-role j-role) + (and (eql (instance-of a-role) + (getf j-role :instance-of)) + (eql (player a-role) + (getf j-role :player)))))) + (is (= (length (roles assoc-1)) 2)) + (is (= (length (roles assoc-2)) 2)) + (is-false (mark-as-deleted-from-json j-req-3)) + (is (= (length (roles assoc-1)) 2)) + (is (= (length (roles assoc-2)) 2))))))))) + + + + (defun run-json-tests() (tear-down-test-db) (it.bese.fiveam:run! 'test-get-fragment-values-from-json-list-general) @@ -1516,4 +2166,11 @@ (it.bese.fiveam:run! 'test-to-json-string-associations) (it.bese.fiveam:run! 'test-to-json-string-fragments) (it.bese.fiveam:run! 'test-to-json-string-topics) - (it.bese.fiveam:run! 'test-get-all-topic-psis)) + (it.bese.fiveam:run! 'test-get-all-topic-psis) + (it.bese.fiveam:run! 'test-delete-from-json-identifiers) + (it.bese.fiveam:run! 'test-delete-from-json-topic) + (it.bese.fiveam:run! 'test-delete-from-json-name) + (it.bese.fiveam:run! 'test-delete-from-json-occurrence) + (it.bese.fiveam:run! 'test-delete-from-json-variant) + (it.bese.fiveam:run! 'test-delete-from-json-association) + (it.bese.fiveam:run! 'test-delete-from-json-role)) \ No newline at end of file

1 0

[isidorus-cvs] r325 - in trunk: docs playground src src/ajax/javascripts src/json src/model src/rest_interface src/unit_tests src/xml/rdf src/xml/xtm
by Lukas Giessmann 10 Oct '10

10 Oct '10

Author: lgiessmann Date: Sun Oct 10 05:41:19 2010 New Revision: 325 Log: merged the branch "new-datamodel" with "trunk" -> resolved all conflicts, except -> the remove-handler of the ui isn't supported by the backend yet Added: trunk/docs/isidorus_data_model.pdf - copied unchanged from r324, /branches/new-datamodel/docs/isidorus_data_model.pdf trunk/docs/isidorus_data_model.vsd - copied unchanged from r324, /branches/new-datamodel/docs/isidorus_data_model.vsd trunk/playground/ - copied from r324, /branches/new-datamodel/playground/ trunk/src/unit_tests/datamodel_test.lisp - copied, changed from r324, /branches/new-datamodel/src/unit_tests/datamodel_test.lisp Removed: trunk/docs/isidorus_classes.pdf Modified: trunk/docs/TODOs.txt trunk/docs/install_isidorus.txt trunk/src/ajax/javascripts/constants.js trunk/src/isidorus.asd trunk/src/json/json_exporter.lisp trunk/src/json/json_importer.lisp trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_constants.lisp trunk/src/json/json_tmcl_validation.lisp trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp trunk/src/model/exceptions.lisp trunk/src/rest_interface/read.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/atom_test.lisp trunk/src/unit_tests/exporter_xtm1.0_test.lisp trunk/src/unit_tests/exporter_xtm2.0_test.lisp trunk/src/unit_tests/fixtures.lisp trunk/src/unit_tests/importer_test.lisp trunk/src/unit_tests/json_test.lisp trunk/src/unit_tests/rdf_exporter_test.lisp trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/unit_tests/versions_test.lisp trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/xtm/exporter.lisp trunk/src/xml/xtm/exporter_xtm1.0.lisp trunk/src/xml/xtm/exporter_xtm2.0.lisp trunk/src/xml/xtm/importer.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp trunk/src/xml/xtm/setup.lisp Modified: trunk/docs/TODOs.txt ============================================================================== --- trunk/docs/TODOs.txt (original) +++ trunk/docs/TODOs.txt Sun Oct 10 05:41:19 2010 @@ -18,14 +18,11 @@ for the concrete name of the import and another one for the logical name of the TM -* reifier: the one missing link to 100% import compatibility... - * admin interface for the * configuration of the sytem: import and export of feeds etc. incl. consolidation of the present feed configuration - * creation and display of topics and associations * TMCL: implement a constraint language --- but the one under ISO FCD ballot, see http://www.itscj.ipsj.or.jp/sc34/open/1053.pdf or Modified: trunk/docs/install_isidorus.txt ============================================================================== --- trunk/docs/install_isidorus.txt (original) +++ trunk/docs/install_isidorus.txt Sun Oct 10 05:41:19 2010 @@ -2,107 +2,7 @@ Installing Isidorus ============================================= -Dependencies -================ - - * Berkeley DB 4.5 or 4.6 including its development files - - * sbcl (1.0.17 or newer) - -and the following Lisp packages: - -Elephant ----------------- - -Install the persistence framework elephant in its unstable version - -darcs get http://www.common-lisp.net/project/elephant/darcs/elephant-unstable/ - -Also install all of its dependencies as described in elephant_install.txt. In particular these are: - * (require 'asdf-install) - * (asdf-install:install 'CL-BASE64) - * (asdf-install:install 'uffi) - -For uffi you need the libc development files (libc6-dev linux-libc-dev -zlib1g-dev under Linux). Under Ubuntu both packages exist also as -Debian packages. Cf. also http://uffi.b9.com/ - -Configure elephant for your platform in my-config.sexp and link its -asd-files to the system-wide install - - -cxml -------- - -CL-USER> (asdf:operate 'asdf:load-op 'asdf-install) -CL-USER> (asdf-install:install 'cxml) - -uuid --------- - -Download the ironclad library from -http://www.method-combination.net/lisp/files/ironclad.tar.gz and link the asd-file to -the sbcl system path. Ironclad is a prerequisite for the UUID library - -Download the UUID library from http://dardoria.net/software/uuid.tar.gz -and link the asd-file to the sbcl system path - -fiveam (unittests) -------------------- - -CL-USER> (asdf-install:install 'fiveam) - -Under Ubuntu Linux, fiveam exists also as a Debian package. - -Installing pathnames ---------------------- - -Pathnames is part of Seibel's libraries (http://www.gigamonkeys.com/book/) and -included with isidorus under src/external. Link the asd-file to the sbcl system path. - -Hunchentoot --------------- - -Hunchentoot (http://www.weitz.de/hunchentoot/) is also -asdf-install'able: - -(asdf-install:install 'hunchentoot) - -It requires a significant number of auxiliary libraries and the -installation hung once during the process. I installed a few libraries -manually then: - - * CL-PPCRE - * CL-FAD - -On restart, the installation completed correctly - -Test: - (asdf:oos 'asdf:load-op :hunchentoot-test) - (hunchentoot:start-server :port 4242) - -cl-json ---------- - -Download the parenscript library: - -darcs get http://common-lisp.net/project/ucw/repos/parenscript - -Link the asd-file to the sbcl system path. - -Download the cl-json library: - -darcs get http://common-lisp.net/project/cl-json/darcs/cl-json - -Link the asd-file to the sbcl system path. - - -Drakma ---------- - -Drakma (http://weitz.de/drakma) also follows the same pattern: - -(asdf-install:install 'drakma) +http://trac.common-lisp.net/isidorus/wiki/InstallIsidorus Starting Isidorus Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Sun Oct 10 05:41:19 2010 @@ -28,6 +28,7 @@ + // --- A kind of enum for the the different pages with an attribute and a value var PAGES = {"home" : "home", "search" : "searchTopic", "edit" : "editTopic", "create" : "createTopic", "current" : ""}; Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sun Oct 10 05:41:19 2010 @@ -150,6 +150,8 @@ :depends-on ("fixtures")) (:file "rdf_exporter_test" :depends-on ("fixtures")) + (:file "datamodel_test" + :depends-on ("fixtures")) (:file "reification_test" :depends-on ("fixtures" "unittests-constants"))) :depends-on ("atom" @@ -204,7 +206,6 @@ :uuid :cl-json)) - (setf sb-impl::*default-external-format* *old-external-format*) ;; Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Sun Oct 10 05:41:19 2010 @@ -8,7 +8,7 @@ (defpackage :json-exporter - (:use :cl :json :datamodel :json-tmcl-constants) + (:use :cl :json :datamodel) (:export :to-json-string :get-all-topic-psis :to-json-string-summary @@ -22,17 +22,22 @@ ;; ============================================================================= ;; --- main json data model ---------------------------------------------------- ;; ============================================================================= -(defgeneric to-json-string (instance &key xtm-id) +(defgeneric to-json-string (instance &key xtm-id revision) (:documentation "converts the Topic Map construct instance to a json string")) -(defun identifiers-to-json-string (parent-construct &key (what 'd:psis)) +(defun identifiers-to-json-string (parent-construct &key (what 'd:psis) + (revision *TM-REVISION*)) "returns the identifiers of a TopicMapConstructC as a json list" + (declare (TopicMapConstructC parent-construct) + (symbol what) + (type (or integer null) revision)) (when (and parent-construct - (or (eql what 'psis) (eql what 'item-identifiers) (eql what 'locators))) + (or (eql what 'psis) + (eql what 'item-identifiers) + (eql what 'locators))) (let ((items - (map 'list #'uri (funcall what parent-construct)))) - (declare (TopicMapConstructC parent-construct)) ;must be a topic for psis and locators + (map 'list #'uri (funcall what parent-construct :revision revision)))) (json:encode-json-to-string items)))) @@ -40,52 +45,67 @@ "returns a resourceRef and resourceData json object" ;(declare (string value datatype)) (if (string= datatype "http://www.w3.org/2001/XMLSchema#anyURI") - (concatenate 'string "\"resourceRef\":" - (let ((inner-value - (let ((ref-topic (when (and (> (length value) 0) - (eql (elt value 0) #\#)) - (get-item-by-id (subseq value 1) :xtm-id xtm-id)))) - (if ref-topic - (concatenate 'string "#" (topicid ref-topic)) - value)))) - (json:encode-json-to-string inner-value)) - ",\"resourceData\":null") + (concatenate + 'string "\"resourceRef\":" + (let ((inner-value + (let ((ref-topic (when (and (> (length value) 0) + (eql (elt value 0) #\#)) + (get-item-by-id (subseq value 1) :xtm-id xtm-id)))) + (if ref-topic + (concatenate 'string "#" (topic-id ref-topic)) + value)))) + (json:encode-json-to-string inner-value)) + ",\"resourceData\":null") (concatenate 'string "\"resourceRef\":null," - "\"resourceData\":{\"datatype\":" - (json:encode-json-to-string datatype) - ",\"value\":" - (json:encode-json-to-string value) "}"))) + "\"resourceData\":{\"datatype\":" + (json:encode-json-to-string datatype) + ",\"value\":" + (json:encode-json-to-string value) "}"))) -(defun ref-topics-to-json-string (topics) +(defun ref-topics-to-json-string (topics &key (revision *TM-REVISION*)) "returns a json string of all psi-uris of the passed topics as a list of lists" + (declare (list topics) + (type (or integer null) revision)) (if topics (let ((psis (json:encode-json-to-string (map 'list #'(lambda(topic) (declare (topicC topic)) - (map 'list #'uri (psis topic))) + (map 'list #'uri (psis topic :revision revision))) topics)))) (declare (list topics)) psis) "null")) -(defun type-to-json-string (parent-elem) +(defun type-to-json-string (parent-elem &key (revision *TM-REVISION*)) "returns a json string of the type of the passed parent-elem" - (declare (TypableC parent-elem)) - (concatenate 'string "\"type\":" - (if (slot-boundp parent-elem 'instance-of) - (json:encode-json-to-string (map 'list #'uri (psis (instance-of parent-elem)))) - "null"))) + (declare (TypableC parent-elem) + (type (or integer null) revision)) + (concatenate + 'string "\"type\":" + (if (instance-of parent-elem :revision revision) + (json:encode-json-to-string + (map 'list #'uri (psis (instance-of parent-elem :revision revision) + :revision revision))) + "null"))) -(defmethod to-json-string ((instance VariantC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance VariantC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "transforms a VariantC object to a json string" + (declare (type (or string null) xtm-id) + (type (or integer null) revision)) (let ((itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (scope - (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance)))) + (concatenate + 'string "\"scopes\":" (ref-topics-to-json-string + (themes instance :revision revision) + :revision revision))) (resourceX (let ((value (when (slot-boundp instance 'charvalue) @@ -97,42 +117,65 @@ (concatenate 'string "{" itemIdentity "," scope "," resourceX "}"))) -(defmethod to-json-string ((instance NameC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance NameC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "transforms a NameC object to a json string" + (declare (type (or string null) xtm-id) + (type (or integer null) revision)) (let ((itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type - (type-to-json-string instance)) + (type-to-json-string instance :revision revision)) (scope - (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance)))) + (concatenate + 'string "\"scopes\":" + (ref-topics-to-json-string (themes instance :revision revision) + :revision revision))) (value (concatenate 'string "\"value\":" (if (slot-boundp instance 'charvalue) (json:encode-json-to-string (charvalue instance)) "null"))) (variant - (if (variants instance) - (concatenate 'string "\"variants\":" - (let ((j-variants "[")) - (loop for variant in (variants instance) - do (setf j-variants - (concatenate 'string j-variants - (json-exporter::to-json-string variant :xtm-id xtm-id) ","))) - (concatenate 'string (subseq j-variants 0 (- (length j-variants) 1)) "]"))) + (if (variants instance :revision revision) + (concatenate + 'string "\"variants\":" + (let ((j-variants "[")) + (loop for variant in (variants instance :revision revision) + do (setf j-variants + (concatenate + 'string j-variants + (json-exporter::to-json-string variant :xtm-id xtm-id + :revision revision) + ","))) + (concatenate + 'string (subseq j-variants 0 + (- (length j-variants) 1)) "]"))) (concatenate 'string "\"variants\":null")))) - (concatenate 'string "{" itemIdentity "," type "," scope "," value "," variant "}"))) + (concatenate 'string "{" itemIdentity "," type "," scope "," value + "," variant "}"))) -(defmethod to-json-string ((instance OccurrenceC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance OccurrenceC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "transforms an OccurrenceC object to a json string" + (declare (type (or string null) xtm-id) + (type (or integer null) revision)) (let ((itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type - (type-to-json-string instance)) + (type-to-json-string instance :revision revision)) (scope - (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance)))) + (concatenate + 'string "\"scopes\":" + (ref-topics-to-json-string (themes instance :revision revision) + :revision revision))) (resourceX (let ((value (when (slot-boundp instance 'charvalue) @@ -144,223 +187,298 @@ (concatenate 'string "{" itemIdentity "," type "," scope "," resourceX "}"))) -(defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "transforms an TopicC object to a json string" + (declare (type (or string null) xtm-id) + (type (or integer null) revision)) (let ((id - (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid instance)))) + (concatenate + 'string "\"id\":" + (json:encode-json-to-string (topic-id instance revision)))) (itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (subjectLocator - (concatenate 'string "\"subjectLocators\":" - (identifiers-to-json-string instance :what 'locators))) + (concatenate + 'string "\"subjectLocators\":" + (identifiers-to-json-string instance :what 'locators + :revision revision))) (subjectIdentifier - (concatenate 'string "\"subjectIdentifiers\":" - (identifiers-to-json-string instance :what 'psis))) + (concatenate + 'string "\"subjectIdentifiers\":" + (identifiers-to-json-string instance :what 'psis + :revision revision))) (instanceOf - (concatenate 'string "\"instanceOfs\":" (ref-topics-to-json-string (list-instanceOf instance)))) + (concatenate + 'string "\"instanceOfs\":" + (ref-topics-to-json-string (list-instanceOf instance :revision revision) + :revision revision))) (name - (concatenate 'string "\"names\":" - (if (names instance) - (let ((j-names "[")) - (loop for item in (names instance) - do (setf j-names - (concatenate 'string j-names (to-json-string item :xtm-id xtm-id) ","))) - (concatenate 'string (subseq j-names 0 (- (length j-names) 1)) "]")) - "null"))) + (concatenate + 'string "\"names\":" + (if (names instance :revision revision) + (let ((j-names "[")) + (loop for item in (names instance :revision revision) + do (setf j-names + (concatenate + 'string j-names (to-json-string item :xtm-id xtm-id + :revision revision) + ","))) + (concatenate 'string (subseq j-names 0 (- (length j-names) 1)) "]")) + "null"))) (occurrence - (concatenate 'string "\"occurrences\":" - (if (occurrences instance) - (let ((j-occurrences "[")) - (loop for item in (occurrences instance) - do (setf j-occurrences - (concatenate 'string j-occurrences (to-json-string item :xtm-id xtm-id) ","))) - (concatenate 'string (subseq j-occurrences 0 (- (length j-occurrences) 1)) "]")) - "null")))) - (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier "," + (concatenate + 'string "\"occurrences\":" + (if (occurrences instance :revision revision) + (let ((j-occurrences "[")) + (loop for item in (occurrences instance :revision revision) + do (setf j-occurrences + (concatenate + 'string j-occurrences + (to-json-string item :xtm-id xtm-id :revision revision) + ","))) + (concatenate + 'string (subseq j-occurrences 0 (- (length j-occurrences) 1)) "]")) + "null")))) + (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," + subjectIdentifier "," instanceOf "," name "," occurrence "}"))) -(defun to-json-topicStub-string (topic) +(defun to-json-topicStub-string (topic &key (revision *TM-REVISION*)) "transforms the passed TopicC object to a topic stub string in the json format, which contains an id, all itemIdentities, all subjectLocators and all subjectIdentifiers" + (declare (type (or TopicC null) topic) + (type (or integer null) revision)) (when topic (let ((id - (concatenate 'string "\"id\":" (json:encode-json-to-string (topicid topic)))) + (concatenate + 'string "\"id\":" + (json:encode-json-to-string (topic-id topic revision)))) (itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string topic :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string topic :what 'item-identifiers + :revision revision))) (subjectLocator - (concatenate 'string "\"subjectLocators\":" - (identifiers-to-json-string topic :what 'locators))) + (concatenate + 'string "\"subjectLocators\":" + (identifiers-to-json-string topic :what 'locators :revision revision))) (subjectIdentifier - (concatenate 'string "\"subjectIdentifiers\":" - (identifiers-to-json-string topic :what 'psis)))) - (declare (TopicC topic)) + (concatenate + 'string "\"subjectIdentifiers\":" + (identifiers-to-json-string topic :what 'psis :revision revision)))) (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier "}")))) -(defmethod to-json-string ((instance RoleC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance RoleC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "transforms an RoleC object to a json string" - (declare (ignorable xtm-id)) + (declare (ignorable xtm-id) + (type (or integer null) revision)) (let ((itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type - (type-to-json-string instance)) + (type-to-json-string instance :revision revision)) (topicRef - (concatenate 'string "\"topicRef\":" - (if (slot-boundp instance 'player) - (json:encode-json-to-string (map 'list #'uri (psis (player instance)))) - "null")))) + (concatenate + 'string "\"topicRef\":" + (if (player instance :revision revision) + (json:encode-json-to-string + (map 'list #'uri (psis (player instance :revision revision) + :revision revision))) + "null")))) (concatenate 'string "{" itemIdentity "," type "," topicRef "}"))) -(defmethod to-json-string ((instance AssociationC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance AssociationC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "transforms an AssociationC object to a json string" (let ((itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type - (type-to-json-string instance)) + (type-to-json-string instance :revision revision)) (scope - (concatenate 'string "\"scopes\":" (ref-topics-to-json-string (themes instance)))) + (concatenate + 'string "\"scopes\":" + (ref-topics-to-json-string (themes instance :revision revision) + :revision revision))) (role - (concatenate 'string "\"roles\":" - (if (roles instance) - (let ((j-roles "[")) - (loop for item in (roles instance) - do (setf j-roles - (concatenate 'string j-roles (to-json-string item :xtm-id xtm-id) ","))) - (concatenate 'string (subseq j-roles 0 (- (length j-roles) 1)) "]")) - "null")))) + (concatenate + 'string "\"roles\":" + (if (roles instance :revision revision) + (let ((j-roles "[")) + (loop for item in (roles instance :revision revision) + do (setf j-roles + (concatenate + 'string j-roles (to-json-string item :xtm-id xtm-id + :revision revision) + ","))) + (concatenate 'string (subseq j-roles 0 (- (length j-roles) 1)) "]")) + "null")))) (concatenate 'string "{" itemIdentity "," type "," scope "," role "}"))) -(defmethod to-json-string ((instance TopicMapC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance TopicMapC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "returns the ItemIdentifier's uri" - (declare (ignorable xtm-id)) - (let ((ii (item-identifiers instance))) + (declare (ignorable xtm-id) + (type (or integer null) revision)) + (let ((ii (item-identifiers instance :revision revision))) (when ii (uri (first ii))))) -(defmethod to-json-string ((instance FragmentC) &key (xtm-id d:*current-xtm*)) +(defmethod to-json-string ((instance FragmentC) &key (xtm-id d:*current-xtm*) + (revision *TM-REVISION*)) "transforms an FragmentC object to a json string, which contains the main topic, all depending topicStubs and all associations depending on the main topic" + (declare (type (or string null) xtm-id) + (type (or integer null) revision)) (let ((main-topic - (concatenate 'string "\"topic\":" - (to-json-string (topic instance) :xtm-id xtm-id))) + (concatenate + 'string "\"topic\":" + (to-json-string (topic instance) :xtm-id xtm-id :revision revision))) (topicStubs - (concatenate 'string "\"topicStubs\":" - (if (referenced-topics instance) - (let ((j-topicStubs "[")) - (loop for item in (referenced-topics instance) - do (setf j-topicStubs (concatenate 'string j-topicStubs - (to-json-topicStub-string item) ","))) - (concatenate 'string (subseq j-topicStubs 0 (- (length j-topicStubs) 1)) "]")) - "null"))) + (concatenate + 'string "\"topicStubs\":" + (if (referenced-topics instance) + (let ((j-topicStubs "[")) + (loop for item in (referenced-topics instance) + do (setf j-topicStubs + (concatenate + 'string j-topicStubs + (to-json-topicStub-string item :revision revision) + ","))) + (concatenate + 'string (subseq j-topicStubs 0 (- (length j-topicStubs) 1)) "]")) + "null"))) (associations - (concatenate 'string "\"associations\":" - (if (associations instance) - (let ((j-associations "[")) - (loop for item in (associations instance) - do (setf j-associations - (concatenate 'string j-associations - (to-json-string item :xtm-id xtm-id) ","))) - (concatenate 'string (subseq j-associations 0 (- (length j-associations) 1)) "]")) - "null"))) + (concatenate + 'string "\"associations\":" + (if (associations instance) + (let ((j-associations "[")) + (loop for item in (associations instance) + do (setf j-associations + (concatenate 'string j-associations + (to-json-string item :xtm-id xtm-id + :revision revision) ","))) + (concatenate 'string (subseq j-associations 0 + (- (length j-associations) 1)) "]")) + "null"))) (tm-ids - (concatenate 'string "\"tmIds\":" - (if (in-topicmaps (topic instance)) - (let ((j-tm-ids "[")) - (loop for item in (in-topicmaps (topic instance)) - ;do (setf j-tm-ids (concatenate 'string j-tm-ids "\"" - ; (d:uri (first (d:item-identifiers item))) "\","))) - do (setf j-tm-ids (concatenate 'string j-tm-ids - (json:encode-json-to-string (d:uri (first (d:item-identifiers item)))) ","))) - (concatenate 'string (subseq j-tm-ids 0 (- (length j-tm-ids) 1)) "]")) - "null")))) - (concatenate 'string "{" main-topic "," topicStubs "," associations "," tm-ids "}"))) + (concatenate + 'string "\"tmIds\":" + (if (in-topicmaps (topic instance)) + (let ((j-tm-ids "[")) + (loop for item in (in-topicmaps (topic instance)) + do (setf j-tm-ids + (concatenate + 'string j-tm-ids + (json:encode-json-to-string + (d:uri (first (d:item-identifiers item + :revision revision)))) + ","))) + (concatenate 'string (subseq j-tm-ids 0 (- (length j-tm-ids) 1)) "]")) + "null")))) + (concatenate 'string "{" main-topic "," topicStubs "," associations + "," tm-ids "}"))) ;; ============================================================================= ;; --- json data summeries ----------------------------------------------------- ;; ============================================================================= -(defun get-all-topic-psis() +(defun get-all-topic-psis(&key (revision *TM-REVISION*)) "returns all topic psis as a json list of the form [[topic-1-psi-1, topic-1-psi-2],[topic-2-psi-1, topic-2-psi-2],...]" + (declare (type (or integer null) revision)) (encode-json-to-string - (remove-if #'null (map 'list #'(lambda(psi-list) - (when psi-list - (map 'list #'uri psi-list))) - (map 'list - #'d:psis - (clean-topics - (elephant:get-instances-by-class 'TopicC))))))) + (remove-if #'null + (map 'list + #'(lambda(psi-list) + (when psi-list + (map 'list #'uri psi-list))) + (map 'list #'psis (get-all-topics revision)))))) -(defun to-json-string-summary (topic) +(defun to-json-string-summary (topic &key (revision *TM-REVISION*)) "creates a json string of called topic element. the following elements are within this summary: *topic id *all identifiers *names (only the real name value) *occurrences (jonly the resourceRef and resourceData elements)" - (declare (TopicC topic)) + (declare (TopicC topic) + (type (or integer null) revision)) (let ((id - (concatenate 'string "\"id\":\"" (topicid topic) "\"")) + (concatenate 'string "\"id\":\"" (topic-id topic revision) "\"")) (itemIdentity - (concatenate 'string "\"itemIdentities\":" - (identifiers-to-json-string topic :what 'item-identifiers))) + (concatenate + 'string "\"itemIdentities\":" + (identifiers-to-json-string topic :what 'item-identifiers + :revision revision))) (subjectLocator - (concatenate 'string "\"subjectLocators\":" - (identifiers-to-json-string topic :what 'locators))) + (concatenate + 'string "\"subjectLocators\":" + (identifiers-to-json-string topic :what 'locators :revision revision))) (subjectIdentifier - (concatenate 'string "\"subjectIdentifiers\":" - (identifiers-to-json-string topic :what 'psis))) + (concatenate + 'string "\"subjectIdentifiers\":" + (identifiers-to-json-string topic :what 'psis :revision revision))) (instanceOf - (concatenate 'string "\"instanceOfs\":" (ref-topics-to-json-string (list-instanceOf topic)))) + (concatenate + 'string "\"instanceOfs\":" + (ref-topics-to-json-string (list-instanceOf topic :revision revision) + :revision revision))) (name - (concatenate 'string "\"names\":" - (if (names topic) - (json:encode-json-to-string (loop for name in (names topic) - when (slot-boundp name 'charvalue) - collect (charvalue name))) - "null"))) + (concatenate + 'string "\"names\":" + (if (names topic :revision revision) + (json:encode-json-to-string + (loop for name in (names topic :revision revision) + when (slot-boundp name 'charvalue) + collect (charvalue name))) + "null"))) (occurrence - (concatenate 'string "\"occurrences\":" - (if (occurrences topic) - (json:encode-json-to-string (loop for occurrence in (occurrences topic) - when (slot-boundp occurrence 'charvalue) - collect (charvalue occurrence))) - "null")))) - (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier "," - instanceOf "," name "," occurrence "}"))) + (concatenate + 'string "\"occurrences\":" + (if (occurrences topic :revision revision) + (json:encode-json-to-string + (loop for occurrence in (occurrences topic :revision revision) + when (slot-boundp occurrence 'charvalue) + collect (charvalue occurrence))) + "null")))) + (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," + subjectIdentifier "," instanceOf "," name "," occurrence "}"))) -(defun make-topic-summary (topic-list) +(defun make-topic-summary (topic-list &key (revision *TM-REVISION*)) "creates a json list of the produced json-strings by to-json-string-summary" + (declare (list topic-list) + (type (or integer null) revision)) (if topic-list (let ((json-string (let ((inner-string nil)) - (concatenate 'string - (loop for topic in topic-list - do (setf inner-string (concatenate 'string inner-string (to-json-string-summary topic) ",")))) + (concatenate + 'string + (loop for topic in topic-list + do (setf inner-string + (concatenate + 'string inner-string + (to-json-string-summary topic :revision revision) ",")))) (subseq inner-string 0 (- (length inner-string) 1))))) (concatenate 'string "[" json-string "]")) - "null")) - - -(defun clean-topics(isas-or-akos) - (remove-if - #'null - (map 'list - #'(lambda(top) - (when (d:find-item-by-revision top 0) - top)) - isas-or-akos))) \ No newline at end of file + "null")) \ No newline at end of file Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Sun Oct 10 05:41:19 2010 @@ -23,32 +23,38 @@ (defun json-to-elem(json-string &key (xtm-id *json-xtm*)) "creates all objects (topics, topic stubs, associations) of the passed json-decoded-list (=fragment)" + (declare (type (or string null) json-string xtm-id)) (when json-string (let ((fragment-values (get-fragment-values-from-json-list (json:decode-json-from-string json-string)))) - (declare (string json-string)) (let ((topic-values (getf fragment-values :topic)) (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 + (rev (get-revision)) ; creates a new revision, equal for all elements of the passed fragment + (tm-ids (getf fragment-values :tm-ids))) + (unless tm-ids + (error "From json-to-elem(): tm-ids must be set")) (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 topicStubs-values - do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) + (xml-importer:with-tm (rev xtm-id (first 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)))))))) + 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 - &key tm ) + &key tm) "creates an association element of the passed json-decoded-list" (elephant:ensure-transaction (:txn-nosync t) (let @@ -57,9 +63,9 @@ (make-identifier 'ItemIdentifierC uri start-revision)) (getf json-decoded-list :itemIdentities))) (instance-of - (psis-to-topic (getf json-decoded-list :type))) + (psis-to-topic (getf json-decoded-list :type) :revision start-revision)) (themes - (json-to-scope (getf json-decoded-list :scopes))) + (json-to-scope (getf json-decoded-list :scopes) start-revision)) (roles (map 'list #'(lambda(role-values) (json-to-role role-values start-revision)) @@ -67,14 +73,14 @@ (declare (list json-decoded-list)) (declare (integer start-revision)) (declare (TopicMapC tm)) - (setf roles (xml-importer::set-standard-role-types roles)) - (add-to-topicmap tm - (make-construct 'AssociationC - :start-revision start-revision - :item-identifiers item-identifiers - :instance-of instance-of - :themes themes - :roles roles))))) + (setf roles (xml-importer::set-standard-role-types roles start-revision)) + (add-to-tm tm + (make-construct 'AssociationC + :start-revision start-revision + :item-identifiers item-identifiers + :instance-of instance-of + :themes themes + :roles roles))))) (defun json-to-role (json-decoded-list start-revision) @@ -87,14 +93,19 @@ (make-identifier 'ItemIdentifierC uri start-revision)) (getf json-decoded-list :itemIdentities))) (instance-of - (psis-to-topic (getf json-decoded-list :type))) + (psis-to-topic (getf json-decoded-list :type) :revision start-revision)) (player - (psis-to-topic (getf json-decoded-list :topicRef)))) + (psis-to-topic (getf json-decoded-list :topicRef) + :revision start-revision))) (declare (list json-decoded-list)) (declare (integer start-revision)) (unless player - (error "Role in association with topicref ~a not complete" (getf json-decoded-list :topicRef))) - (list :instance-of instance-of :player player :item-identifiers item-identifiers))))) + (error "Role in association with topicref ~a not complete" + (getf json-decoded-list :topicRef))) + (list :instance-of instance-of + :player player + :item-identifiers item-identifiers + :start-revision start-revision))))) (defun json-merge-topic (json-decoded-list start-revision @@ -103,13 +114,11 @@ elements from the json-decoded-list" (when json-decoded-list (elephant:ensure-transaction (:txn-nosync t) -; (let ((top -; (d:get-item-by-id -; (getf json-decoded-list :id) -; :revision start-revision -; :xtm-id xtm-id))) - (let ((top (json-to-stub json-decoded-list start-revision - :tm tm :xtm-id xtm-id))) + (let ((top + (d:get-item-by-id + (getf json-decoded-list :id) + :revision start-revision + :xtm-id xtm-id))) (declare (list json-decoded-list)) (declare (integer start-revision)) (declare (TopicMapC tm)) @@ -118,14 +127,19 @@ (let ((instanceof-topics (remove-duplicates (map 'list - #'psis-to-topic + #'(lambda(psis) + (psis-to-topic psis :revision start-revision)) (getf json-decoded-list :instanceOfs))))) + (loop for name-values in (getf json-decoded-list :names) do (json-to-name name-values top start-revision)) + (loop for occurrence-values in (getf json-decoded-list :occurrences) do (json-to-occurrence occurrence-values top start-revision)) (dolist (instanceOf-top instanceof-topics) - (json-create-instanceOf-association instanceOf-top top start-revision :tm tm)) + (json-create-instanceOf-association instanceOf-top top start-revision + :tm tm)) + ;(add-to-tm tm top) ; will be done in "json-to-stub" top))))) @@ -144,7 +158,13 @@ (subject-locators (map 'list #'(lambda(uri) (make-identifier 'SubjectLocatorC uri start-revision)) - (getf json-decoded-list :subjectLocators)))) + (getf json-decoded-list :subjectLocators))) + (topic-ids + (when (getf json-decoded-list :id) + (list + (make-construct 'TopicIdentificationC + :uri (getf json-decoded-list :id) + :xtm-id xtm-id))))) ;; all topic stubs has to be added top a topicmap object in this method ;; becuase the only one topic that is handled in "json-merge-topic" ;; is the main topic of the fragment @@ -153,9 +173,8 @@ :item-identifiers item-identifiers :locators subject-locators :psis subject-identifiers - :topicid (getf json-decoded-list :id) - :xtm-id xtm-id))) - (add-to-topicmap tm top) + :topic-identifiers topic-ids))) + (add-to-tm tm top) top))))) @@ -164,13 +183,13 @@ (when json-decoded-list (let ((themes - (json-to-scope (getf json-decoded-list :scopes))) + (json-to-scope (getf json-decoded-list :scopes) start-revision)) (item-identifiers (map 'list #'(lambda(uri) (make-identifier 'ItemIdentifierC uri start-revision)) (getf json-decoded-list :itemIdentities))) (instance-of - (psis-to-topic (getf json-decoded-list :type))) + (psis-to-topic (getf json-decoded-list :type) :revision start-revision)) (occurrence-value (json-to-resourceX json-decoded-list))) @@ -178,7 +197,7 @@ (error "OccurrenceC: one of resourceRef and resourceData must be set")) (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes themes :item-identifiers item-identifiers :instance-of instance-of @@ -192,27 +211,30 @@ (declare (symbol classsymbol)) (declare (string uri)) (declare (integer start-revision)) - (let ((id (make-instance classsymbol - :uri uri - :start-revision start-revision))) - id)) + (make-construct classsymbol + :uri uri + :start-revision start-revision)) -(defun json-to-scope (json-decoded-list) +(defun json-to-scope (json-decoded-list start-revision) "Generate set of themes (= topics) from this scope element and return that set. If the input is nil, the list of themes is empty" (when json-decoded-list (let ((tops - (map 'list #'psis-to-topic json-decoded-list))) + (map 'list #'(lambda(psis) + (psis-to-topic psis :revision start-revision)) + json-decoded-list))) (declare (list json-decoded-list)) (unless (>= (length tops) 1) (error "need at least one topic in a scope")) tops))) -(defun psis-to-topic(psis) +(defun psis-to-topic(psis &key (revision *TM-REVISION*)) "searches for a topic of the passed psis-list describing exactly one topic" + (declare (list psis) + (type (or integer null) revision)) (when psis (let ((top (let ((psi @@ -221,9 +243,8 @@ 'd:PersistentIdC 'd:uri uri) return (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri uri)))) - (format t "psi: ~a~%" psi) (when psi - (d:identified-construct psi))))) + (d:identified-construct psi :revision revision))))) (unless top (error (make-condition 'missing-reference-error :message (format nil "psis-to-topic: could not resolve reference ~a" psis)))) @@ -239,23 +260,20 @@ (getf json-decoded-list :itemIdentities))) (namevalue (getf json-decoded-list :value)) (themes - (json-to-scope (getf json-decoded-list :scopes))) + (json-to-scope (getf json-decoded-list :scopes) start-revision)) (instance-of - (psis-to-topic (getf json-decoded-list :type)))) - ;(declare (list json-decoded-list)) causes problems with sbcl 1.0.34.0.debian - ;(declare (TopicC top)) + (psis-to-topic (getf json-decoded-list :type) :revision start-revision))) (unless namevalue (error "A name must have exactly one namevalue")) (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue namevalue :instance-of instance-of :item-identifiers item-identifiers :themes themes))) (loop for variant in (getf json-decoded-list :variants) do (json-to-variant variant name start-revision)) - ;(json-to-variant (getf json-decoded-list :variants) name start-revision) name)))) @@ -267,19 +285,20 @@ (make-identifier 'ItemIdentifierC uri start-revision)) (getf json-decoded-list :itemIdentities))) (themes - (remove-duplicates (append (d:themes name) - (json-to-scope (getf json-decoded-list :scopes))))) + (remove-duplicates + (append (d:themes name) + (json-to-scope (getf json-decoded-list :scopes) + start-revision)))) (variant-value (json-to-resourceX json-decoded-list))) (declare (list json-decoded-list)) - ;(declare (NameC name)) (make-construct 'VariantC :start-revision start-revision :item-identifiers item-identifiers :themes themes :charvalue (getf variant-value :data) :datatype (getf variant-value :type) - :name name)))) + :parent name)))) (defun json-to-resourceX(json-decoded-list) @@ -309,23 +328,19 @@ from all the others in that it is not modelled one to one, but following the suggestion of the XTM 2.0 spec (4.9) and the TMDM (7.2) as an association" - - (declare (TopicC supertype)) - (declare (TopicC player2-obj)) - (declare (TopicMapC tm)) + (declare (TopicC supertype player2-obj) + (TopicMapC tm)) (let ((associationtype - (get-item-by-psi constants:*type-instance-psi*)) + (get-item-by-psi constants:*type-instance-psi* :revision start-revision)) (roletype1 - (get-item-by-psi constants:*type-psi*)) + (get-item-by-psi constants:*type-psi* :revision start-revision)) (roletype2 - (get-item-by-psi constants:*instance-psi*)) + (get-item-by-psi constants:*instance-psi* :revision start-revision)) (player1 supertype)) - (unless (and associationtype roletype1 roletype2) (error "Error in the creation of an instanceof association: core topics are missing")) - - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC @@ -333,8 +348,12 @@ :themes nil :start-revision start-revision :instance-of associationtype - :roles (list (list :instance-of roletype1 :player player1) - (list :instance-of roletype2 :player player2-obj)))))) + :roles (list (list :instance-of roletype1 + :player player1 + :start-revision start-revision) + (list :instance-of roletype2 + :player player2-obj + :start-revision start-revision)))))) (defun get-fragment-values-from-json-list(json-decoded-list) @@ -358,7 +377,7 @@ (setf tm-ids (cdr j-elem))) (t (error "json-importer:get-fragment-values-from-json-string: - bad item-specifier found in json-list (~a)" (car j-elem))))) + bad item-specifier found in json-list")))) (unless topic (error "json-importer:get-fragment-values-from-json-string: the element topic must be set")) (unless (= (length tm-ids) 1) Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Sun Oct 10 05:41:19 2010 @@ -11,316 +11,25 @@ ;; ============================================================================= -;; --- mark-as-deleted handler ------------------------------------------------- -;; ============================================================================= -(defun mark-as-deleted-from-json (json-data) - "Marks an object that is specified by the given JSON data as deleted." - (declare (string json-data)) - (let ((values (json:decode-json-from-string json-data))) - (let ((type nil) - (topics nil) - (associations nil) - (parent-topic nil) - (parent-name nil) - (names nil) - (variants nil) - (occurrences nil) - (parent-association nil) - (roles nil) - (rev (get-revision))) - (loop for entry in values - when (consp entry) - do (let ((st (car entry)) - (nd (cdr entry))) - (cond ((eql st :type) (setf type nd)) - ((eql st :topics) (setf topics nd)) - ((eql st :associations) (setf associations nd)) - ((eql st :parent-topic) (setf parent-topic nd)) - ((eql st :parent-name) (setf parent-name nd)) - ((eql st :names) (setf names nd)) - ((eql st :variants) (setf variants nd)) - ((eql st :occurrences) (setf occurrences nd)) - ((eql st :parent-association) (setf parent-association nd)) - ((eql st :roles) (setf roles nd))))) - (cond ((string= type "Topic") - (delete-topics-from-json topics rev)) - ((string= type "Association") - (delete-associations-from-json associations rev)) - ((string= type "Occurrence") - (delete-occurrences-from-json occurrences parent-topic rev)) - ((string= type "Name") - (delete-names-from-json names parent-topic rev)) - ((string= type "Variant") - (delete-variants-from-json variants parent-topic parent-name rev)) - ((string= type "Role") - (delete-roles-from-json roles parent-association rev)) - (t - (error "From mark-as-deleted-from-json(): the type ~a is not defined" - type)))))) - - -(defun find-role-from-json (parent-association json-plist) - (declare (AssociationC parent-association) (list json-plist)) - (let ((found-role - (find-if - #'(lambda(role) - (let ((type (when (getf json-plist :type) - (d:get-item-by-psi (first (getf json-plist :type))))) - (player (when (getf json-plist :topicRef) - (d:get-item-by-psi - (first (getf json-plist :topicRef)))))) - (and (eql type (d:instance-of role)) - (eql player (d:player role))))) - (d:roles parent-association)))) - found-role)) - - -(defun delete-roles-from-json (roles parent-association revision) - (declare (list roles parent-association) (integer revision)) - (let ((err "From delete-roles-from-association(): ") - (parent-assoc - (find-association-from-json - (json-importer::get-association-values-from-json-list - parent-association)))) - (unless parent-assoc - (error "~a~a not found" err parent-association)) - (dolist (j-role roles) - (let ((plist (json-importer::get-role-values-from-json-list j-role))) - (let ((role (find-role-from-json parent-assoc plist))) - (unless role - (error "~a~a not found" err plist)) - (format t "~a~%" role) - (mark-as-deleted role :revision revision)))))) - - -(defun find-variant-from-json (parent-name json-plist) - (declare (NameC parent-name) (list json-plist)) - (let ((err "From find-variant-from-json(): ")) - (let ((found-var - (find-if - #'(lambda(var) - (let ((datatype (cond ((getf json-plist :datatype) - (getf json-plist :datatype)) - ((getf json-plist :resourceRef) - constants:*xml-uri*) - ((getf json-plist :resourceData) - (let ((val - (getf - (getf json-plist :resourceData) - :datatype))) - (if val val constants:*xml-string*))) - (t - constants:*xml-string*))) - (charvalue (cond ((getf json-plist :resourceRef) - (getf json-plist :resourceRef)) - ((getf json-plist :resourceData) - (getf (getf json-plist :resourceData) - :value)) - (t - ""))) - (scopes nil)) - (loop for scope-entry in (getf json-plist :scopes) - do (let ((top (d:get-item-by-psi (first scope-entry)))) - (unless top - (error "~a ~a not found" err (first scope-entry))) - (pushnew top scopes))) - (and (not (set-exclusive-or scopes (d:themes var))) - (string= datatype (d:datatype var)) - (string= charvalue (d:charvalue var))))) - (d:variants parent-name :revision 0)))) - found-var))) - - -(defun delete-variants-from-json (variants parent-psi parent-name revision) - (declare (string parent-psi) (list variants parent-name)) - (let ((err "From delete-variants-from-json(): ") - (parent-topic (d:get-item-by-psi parent-psi))) - (unless parent-topic - (error "~a~a not found" err parent-psi)) - (let ((v-name - (find-name-from-json - parent-topic - (json-importer::get-name-values-from-json-list parent-name)))) - (unless v-name - (error "~a~a not found" err parent-name)) - (dolist (j-variant variants) - (let ((plist - (json-importer::get-variant-values-from-json-list j-variant))) - (let ((variant (find-variant-from-json v-name plist))) - (unless variant - (error "~a~a not found" err plist)) - (mark-as-deleted variant :revision revision))))))) - - -(defun find-name-from-json(parent-topic json-plist) - (declare (TopicC parent-topic) (list json-plist)) - (let ((err "From find-name-from-json(): ")) - (let ((found-name - (find-if - #'(lambda(name) - (let ((type (when (getf json-plist :type) - (d:get-item-by-psi (first (getf json-plist :type))))) - (charvalue (if (getf json-plist :value) - (getf json-plist :value) - "")) - (scopes nil)) - (loop for scope-entry in (getf json-plist :scopes) - do (let ((top (d:get-item-by-psi (first scope-entry)))) - (unless top - (error "~a ~a not found" err (first scope-entry))) - (pushnew top scopes))) - (and (eql type (d:instance-of name)) - (not (set-exclusive-or scopes (d:themes name))) - (string= charvalue (d:charvalue name))))) - (names parent-topic :revision 0)))) - found-name))) - - -(defun delete-names-from-json (names parent-psi revision) - (declare (list names) (string parent-psi) (integer revision)) - (let ((parent-topic (d:get-item-by-psi parent-psi)) - (err "From delete-names-from-json(): ")) - (unless parent-topic - (error "~a~a not found" - err parent-psi)) - (dolist (j-name names) - (let ((plist (json-importer::get-name-values-from-json-list j-name))) - (let ((name (find-name-from-json parent-topic plist))) - (unless name - (error "~a~a not found" err plist)) - (mark-as-deleted name :revision revision)))))) - - -(defun find-occurrence-from-json(parent-topic json-plist) - (declare (TopicC parent-topic) (list json-plist)) - (let ((err "From find-occurrence-from-json(): ")) - (let ((found-occ - (find-if - #'(lambda(occ) - (let ((type (when (getf json-plist :type) - (d:get-item-by-psi (first (getf json-plist :type))))) - (datatype (cond ((getf json-plist :datatype) - (getf json-plist :datatype)) - ((getf json-plist :resourceRef) - constants:*xml-uri*) - ((getf json-plist :resourceData) - (let ((val - (getf - (getf json-plist :resourceData) - :datatype))) - (if val val constants:*xml-string*))) - (t - constants:*xml-string*))) - (charvalue (cond ((getf json-plist :resourceRef) - (getf json-plist :resourceRef)) - ((getf json-plist :resourceData) - (getf (getf json-plist :resourceData) - :value)) - (t - ""))) - (scopes nil)) - (loop for scope-entry in (getf json-plist :scopes) - do (let ((top (d:get-item-by-psi (first scope-entry)))) - (unless top - (error "~a ~a not found" err (first scope-entry))) - (pushnew top scopes))) - (and (eql type (d:instance-of occ)) - (not (set-exclusive-or scopes (d:themes occ))) - (string= datatype (d:datatype occ)) - (string= charvalue (d:charvalue occ))))) - (occurrences parent-topic :revision 0)))) - found-occ))) - - -(defun delete-occurrences-from-json(occurrences parent-psi revision) - (declare (list occurrences) (string parent-psi) (integer revision)) - (let ((parent-topic (d:get-item-by-psi parent-psi)) - (err "From delete-occurrences-from-json(): ")) - (unless parent-topic - (error "~a~a not found" err parent-psi)) - (dolist (j-occ occurrences) - (let ((plist (json-importer::get-occurrence-values-from-json-list j-occ))) - (let ((occ (find-occurrence-from-json parent-topic plist))) - (unless occ - (error "~a~a not found" err plist)) - (mark-as-deleted occ :revision revision)))))) - - -(defun find-association-from-json (json-plist) - (declare (list json-plist)) - (let ((type-assocs - (elephant:get-instances-by-value - 'd:AssociationC 'd:instance-of - (d:get-item-by-psi (first (getf json-plist :type))))) - (scopes nil) - (err "From find-association-from-json(): ")) - (loop for scope-entry in (getf json-plist :scopes) - do (let ((top (d:get-item-by-psi (first scope-entry)))) - (unless top - (error "~a ~a not found" err (first scope-entry))) - (pushnew top scopes))) - (let ((scope-assocs - (loop for assoc in type-assocs - when (not (set-exclusive-or scopes (themes assoc))) - collect assoc))) - (loop for assoc in scope-assocs - when (let ((found-roles - (loop for j-role in (getf json-plist :roles) - when (let ((j-player (when (getf j-role :topicRef) - (d:get-item-by-psi (first (getf j-role :topicRef))))) - (j-type (when (getf j-role :type) - (d:get-item-by-psi (first (getf j-role :type)))))) - (find-if #'(lambda(role) - (and (eql (instance-of role) j-type) - (eql (player role) j-player))) - (roles assoc))) - collect j-role))) - (= (length (roles assoc)) (length (getf json-plist :roles)) - (length found-roles))) - return assoc)))) - - -(defun delete-associations-from-json (associations revision) - (declare (list associations) (integer revision)) - (dolist (j-assoc associations) - (let ((plist (json-importer::get-association-values-from-json-list j-assoc)) - (err "From delete-associations-from-json(): ")) - (let ((assoc (find-association-from-json plist))) - (unless assoc - (error "~a ~a not found" err plist)) - (mark-as-deleted assoc :revision revision))))) - - -(defun delete-topics-from-json (topics revision) - (declare (list topics) (integer revision)) - (let ((psis nil)) - (dolist (uri topics) - (let ((psi (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri uri))) - (unless psi - (error "From delete-topics-from-json(): PSI ~a not found" uri)) - (pushnew psi psis))) - (let ((tops - (remove-duplicates - (map 'list #'d:identified-construct psis)))) - (dolist (top tops) - (let ((psi (uri (first (psis top))))) - (mark-as-deleted top :source-locator psi :revision revision)))))) - - -;; ============================================================================= ;; --- all fragment constraints ------------------------------------------------ ;; ============================================================================= -(defun get-constraints-of-fragment(topic-psis &key (treat-as 'type)) +(defun get-constraints-of-fragment(topic-psis &key + (treat-as 'type) (revision *TM-REVISION*)) "Returns a json string with all constraints of this topic-psis. - topic-psis must contain one item if it is treated as instance other wiese there can be more psis - then the fragment will be treated as an instanceOf all passed psis." - (let ((associationtype (get-item-by-psi *associationtype-psi*)) - (associationtype-constraint (is-type-constrained :what *associationtype-constraint-psi*)) + topic-psis must contain one item if it is treated as instance otherwise# + there can be more psis then the fragment will be treated as an instanceOf + all passed psis." + (declare (type (or integer null) revision) + (symbol treat-as) + (list topic-psis)) + (let ((associationtype (get-item-by-psi *associationtype-psi* :revision revision)) + (associationtype-constraint (is-type-constrained + :what *associationtype-constraint-psi* + :revision revision)) (topics nil)) (when (and (not (eql treat-as 'type)) (> (length topic-psis) 1)) (error "From get-constraints-of-fragment: when treat-as is set ot instance there must be exactly one item in topic-psis!")) - (loop for topic-psi in topic-psis do (let ((psi (elephant:get-instance-by-value 'PersistentIdC 'uri topic-psi))) @@ -330,78 +39,110 @@ (when topics (let ((topic-constraints (let ((value - (get-constraints-of-topic topics :treat-as treat-as))) + (get-constraints-of-topic topics :treat-as treat-as + :revision revision))) (concatenate 'string "\"topicConstraints\":" value)))) (let ((available-associations (remove-duplicates (loop for topic in topics - append (get-available-associations-of-topic topic :treat-as treat-as))))) + append (get-available-associations-of-topic + topic :treat-as treat-as :revision revision))))) (dolist (item available-associations) - (topictype-p item associationtype associationtype-constraint)) + (topictype-p item associationtype associationtype-constraint + nil revision)) (let ((associations-constraints - (concatenate 'string "\"associationsConstraints\":" - (let ((inner-associations-constraints "[")) - (loop for available-association in available-associations - do (let ((value - (get-constraints-of-association available-association))) - (setf inner-associations-constraints - (concatenate 'string inner-associations-constraints value ",")))) - (if (string= inner-associations-constraints "[") - (setf inner-associations-constraints "null") - (setf inner-associations-constraints - (concatenate 'string (subseq inner-associations-constraints 0 (- (length inner-associations-constraints) 1)) "]"))))))) + (concatenate + 'string "\"associationsConstraints\":" + (let ((inner-associations-constraints "[")) + (loop for available-association in available-associations + do (let ((value + (get-constraints-of-association + available-association :revision revision))) + (setf inner-associations-constraints + (concatenate 'string inner-associations-constraints + value ",")))) + (if (string= inner-associations-constraints "[") + (setf inner-associations-constraints "null") + (setf inner-associations-constraints + (concatenate + 'string + (subseq inner-associations-constraints 0 + (- (length inner-associations-constraints) 1)) + "]"))))))) (let ((json-string (concatenate 'string - "{" topic-constraints "," associations-constraints "}"))) + "{" topic-constraints "," associations-constraints + "}"))) json-string))))))) ;; ============================================================================= ;; --- all association constraints --------------------------------------------- ;; ============================================================================= -(defun get-constraints-of-association (associationtype-topic) +(defun get-constraints-of-association (associationtype-topic &key + (revision *TM-REVISION*)) "Returns a list of constraints which are describing associations of the passed associationtype-topic." + (declare (TopicC associationtype-topic) + (type (or integer null) revision)) (let ((constraint-topics - (get-all-constraint-topics-of-association associationtype-topic))) + (get-all-constraint-topics-of-association associationtype-topic + :revision revision))) (let ((associationtype (concatenate 'string "\"associationType\":" - (json-exporter::identifiers-to-json-string associationtype-topic))) + (json-exporter::identifiers-to-json-string + associationtype-topic :revision revision))) (associationtypescope-constraints - (let ((value (get-typescope-constraints associationtype-topic :what 'association))) + (let ((value (get-typescope-constraints associationtype-topic + :what 'association + :revision revision))) (concatenate 'string "\"scopeConstraints\":" value))) (associationrole-constraints (let ((value - (get-associationrole-constraints (getf constraint-topics :associationrole-constraints)))) + (get-associationrole-constraints + (getf constraint-topics :associationrole-constraints) + :revision revision))) (concatenate 'string "\"associationRoleConstraints\":" value))) (roleplayer-constraints (let ((value - (get-roleplayer-constraints (getf constraint-topics :roleplayer-constraints)))) + (get-roleplayer-constraints + (getf constraint-topics :roleplayer-constraints) + :revision revision))) (concatenate 'string "\"rolePlayerConstraints\":" value))) (otherrole-constraints (let ((value - (get-otherrole-constraints (getf constraint-topics :otherrole-constraints)))) + (get-otherrole-constraints + (getf constraint-topics :otherrole-constraints) + :revision revision))) (concatenate 'string "\"otherRoleConstraints\":" value)))) (let ((json-string - (concatenate 'string "{" associationtype "," associationrole-constraints "," roleplayer-constraints "," - otherrole-constraints "," associationtypescope-constraints "}"))) + (concatenate 'string "{" associationtype "," associationrole-constraints + "," roleplayer-constraints "," + otherrole-constraints "," associationtypescope-constraints + "}"))) json-string)))) -(defun get-otherrole-constraints (constraint-topics) +(defun get-otherrole-constraints (constraint-topics &key (revision *TM-REVISION*)) "Returns a list of the form - ((::role <topic> :player <topic> :otherrole <topic> :othertopic <topic> :card-min <string> :card-max <string>) <...>) + ((::role <topic> :player <topic> :otherrole <topic> :othertopic <topic> + :card-min <string> :card-max <string>) <...>) which describes an otherrole constraint for the parent-association of a give type." - (let ((applies-to (get-item-by-psi *applies-to-psi*)) - (constraint-role (get-item-by-psi *constraint-role-psi*)) - (topictype-role (get-item-by-psi *topictype-role-psi*)) - (roletype-role (get-item-by-psi *roletype-role-psi*)) - (othertopictype-role (get-item-by-psi *othertopictype-role-psi*)) - (otherroletype-role (get-item-by-psi *otherroletype-role-psi*)) - (roletype (get-item-by-psi *roletype-psi*)) - (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*)) - (topictype (get-item-by-psi *topictype-psi*)) - (topictype-constraint (is-type-constrained))) + (declare (list constraint-topics) + (type (or integer null) revision)) + (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) + (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision)) + (othertopictype-role (get-item-by-psi *othertopictype-role-psi* + :revision revision)) + (otherroletype-role (get-item-by-psi *otherroletype-role-psi* + :revision revision)) + (roletype (get-item-by-psi *roletype-psi* :revision revision)) + (roletype-constraint (is-type-constrained :what *roletype-constraint-psi* + :revision revision)) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (is-type-constrained :revision revision))) (let ((otherrole-constraints (loop for constraint-topic in constraint-topics append (let ((players nil) @@ -409,13 +150,22 @@ (otherplayers nil) (otherroletypes nil) (constraint-list - (get-constraint-topic-values constraint-topic))) - (loop for role in (player-in-roles constraint-topic) - when (and (eq constraint-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - do (loop for other-role in (roles (parent role)) - do (let ((current-player (player other-role)) - (current-role (instance-of other-role))) + (get-constraint-topic-values constraint-topic + :revision revision))) + (loop for role in (player-in-roles constraint-topic + :revision revision) + when (and (eq constraint-role + (instance-of role :revision revision)) + (eq applies-to (instance-of + (parent role :revision revision) + :revision revision))) + do (loop for other-role in (roles + (parent role :revision revision) + :revision revision) + do (let ((current-player + (player other-role :revision revision)) + (current-role + (instance-of other-role :revision revision))) (cond ((eq topictype-role current-role) (push current-player players)) @@ -425,26 +175,47 @@ (push current-player otherplayers)) ((eq otherroletype-role current-role) (push current-player otherroletypes)))))) - (when (and (append players roletypes otherplayers otherroletypes) - (or (not players) (not roletypes) (not otherplayers) (not otherroletypes))) + (when (and (append + players roletypes otherplayers otherroletypes) + (or (not players) (not roletypes) + (not otherplayers) (not otherroletypes))) (error "otherroletype-constraint ~a is not complete:~%players: ~a~%roletypes: ~a~%otherplayers: ~a~%otherroletypes: ~a~%" (uri (first (psis constraint-topic))) - (map 'list #'(lambda(x)(uri (first (psis x)))) players) - (map 'list #'(lambda(x)(uri (first (psis x)))) roletypes) - (map 'list #'(lambda(x)(uri (first (psis x)))) otherplayers) - (map 'list #'(lambda(x)(uri (first (psis x)))) otherroletypes))) + (map 'list + #'(lambda(x) + (uri (first (psis x :revision revision)))) + players) + (map 'list + #'(lambda(x) + (uri (first (psis x :revision revision)))) + roletypes) + (map 'list + #'(lambda(x) + (uri (first (psis x :revision revision)))) + otherplayers) + (map 'list + #'(lambda(x) + (uri (first (psis x :revision revision)))) + otherroletypes))) (let ((cross-product-1 (loop for player in players append (loop for roletype in roletypes - collect (list :player player :role roletype)))) + collect (list :player player + :role roletype)))) (cross-product-2 (loop for otherplayer in otherplayers append (loop for otherroletype in otherroletypes - collect (list :otherplayer otherplayer :otherrole otherroletype))))) + collect + (list :otherplayer otherplayer + :otherrole otherroletype))))) (let ((cross-product (loop for tupple-1 in cross-product-1 - append (loop for tupple-2 in cross-product-2 - collect (append tupple-1 tupple-2 (list :constraint constraint-list)))))) + append + (loop for tupple-2 in cross-product-2 + collect + (append + tupple-1 tupple-2 + (list :constraint constraint-list)))))) cross-product)))))) (let ((involved-topic-tupples (remove-duplicates @@ -453,10 +224,14 @@ (role-type (getf otherrole-constraint :role)) (otherplayer (getf otherrole-constraint :otherplayer)) (otherrole-type (getf otherrole-constraint :otherrole))) - (topictype-p player) - (topictype-p role-type roletype roletype-constraint) - (topictype-p otherplayer) - (topictype-p otherrole-type roletype roletype-constraint) + (topictype-p player topictype topictype-constraint + nil revision) + (topictype-p role-type roletype roletype-constraint + nil revision) + (topictype-p otherplayer topictype topictype-constraint + nil revision) + (topictype-p otherrole-type roletype roletype-constraint + nil revision) (list :player player :role role-type :otherplayer otherplayer @@ -471,105 +246,176 @@ do (let ((constraint-lists (remove-duplicate-constraints (loop for otherrole-constraint in otherrole-constraints - when (and (eq (getf otherrole-constraint :player) (getf involved-topic-tupple :player)) - (eq (getf otherrole-constraint :role) (getf involved-topic-tupple :role)) - (eq (getf otherrole-constraint :otherplayer) (getf involved-topic-tupple :otherplayer)) - (eq (getf otherrole-constraint :otherrole) (getf involved-topic-tupple :otherrole))) + when (and (eq (getf otherrole-constraint :player) + (getf involved-topic-tupple :player)) + (eq (getf otherrole-constraint :role) + (getf involved-topic-tupple :role)) + (eq (getf otherrole-constraint :otherplayer) + (getf involved-topic-tupple :otherplayer)) + (eq (getf otherrole-constraint :otherrole) + (getf involved-topic-tupple :otherrole))) collect (getf otherrole-constraint :constraint))))) (when (> (length constraint-lists) 1) (error "found contrary otherrole-constraints:~%player: ~a~%role: ~a~%otherplayer: ~a~%otherrole: ~a~% ~a~%" - (uri (first (psis (getf involved-topic-tupple :player)))) - (uri (first (psis (getf involved-topic-tupple :role)))) - (uri (first (psis (getf involved-topic-tupple :otherplayer)))) - (uri (first (psis (getf involved-topic-tupple :otherrole)))) + (uri (first (psis (getf involved-topic-tupple :player) + :revision revision))) + (uri (first (psis (getf involved-topic-tupple :role) + :revision revision))) + (uri (first (psis (getf involved-topic-tupple :otherplayer) + :revision revision))) + (uri (first (psis (getf involved-topic-tupple :otherrole) + :revision revision))) constraint-lists)) (let ((json-player-type - (concatenate 'string "\"playerType\":" - (topics-to-json-list (getf (list-subtypes (getf involved-topic-tupple :player) nil nil) :subtypes)))) + (concatenate + 'string "\"playerType\":" + (topics-to-json-list + (getf (list-subtypes (getf involved-topic-tupple :player) + nil nil nil nil revision) + :subtypes) :revision revision))) (json-player - (concatenate 'string "\"players\":" - (topics-to-json-list - (list-instances (getf involved-topic-tupple :player) topictype topictype-constraint)))) + (concatenate + 'string "\"players\":" + (topics-to-json-list + (list-instances (getf involved-topic-tupple :player) + topictype topictype-constraint revision) + :revision revision))) (json-role - (concatenate 'string "\"roleType\":" - (topics-to-json-list - (getf (list-subtypes (getf involved-topic-tupple :role) roletype roletype-constraint) :subtypes)))) + (concatenate + 'string "\"roleType\":" + (topics-to-json-list + (getf (list-subtypes (getf involved-topic-tupple :role) + roletype roletype-constraint nil + nil revision) + :subtypes) :revision revision))) (json-otherplayer-type - (concatenate 'string "\"otherPlayerType\":" - (topics-to-json-list (getf (list-subtypes (getf involved-topic-tupple :otherplayer) nil nil) :subtypes)))) + (concatenate + 'string "\"otherPlayerType\":" + (topics-to-json-list + (getf (list-subtypes + (getf involved-topic-tupple :otherplayer) + nil nil nil nil revision) :subtypes) + :revision revision))) (json-otherplayer - (concatenate 'string "\"otherPlayers\":" - (topics-to-json-list - (list-instances (getf involved-topic-tupple :otherplayer) topictype topictype-constraint)))) + (concatenate + 'string "\"otherPlayers\":" + (topics-to-json-list + (list-instances (getf involved-topic-tupple :otherplayer) + topictype topictype-constraint revision) + :revision revision))) (json-otherrole - (concatenate 'string "\"otherRoleType\":" - (topics-to-json-list - (getf (list-subtypes (getf involved-topic-tupple :otherrole) roletype roletype-constraint) :subtypes)))) + (concatenate + 'string "\"otherRoleType\":" + (topics-to-json-list + (getf (list-subtypes + (getf involved-topic-tupple :otherrole) + roletype roletype-constraint nil nil revision) + :subtypes) :revision revision))) (card-min - (concatenate 'string "\"cardMin\":" (getf (first constraint-lists) :card-min))) + (concatenate 'string "\"cardMin\":" + (getf (first constraint-lists) :card-min))) (card-max - (concatenate 'string "\"cardMax\":" (getf (first constraint-lists) :card-max)))) + (concatenate 'string "\"cardMax\":" + (getf (first constraint-lists) :card-max)))) (setf cleaned-otherrole-constraints (concatenate 'string cleaned-otherrole-constraints - "{" json-player-type "," json-player "," json-role "," json-otherplayer-type "," json-otherplayer "," json-otherrole "," card-min "," card-max "},"))))) + "{" json-player-type "," json-player "," + json-role "," json-otherplayer-type "," + json-otherplayer "," json-otherrole "," + card-min "," card-max "},"))))) (if (string= cleaned-otherrole-constraints "[") (setf cleaned-otherrole-constraints "null") (setf cleaned-otherrole-constraints - (concatenate 'string (subseq cleaned-otherrole-constraints 0 (- (length cleaned-otherrole-constraints) 1)) "]"))) + (concatenate + 'string (subseq cleaned-otherrole-constraints 0 + (- (length cleaned-otherrole-constraints) 1)) + "]"))) cleaned-otherrole-constraints))))) -(defun get-roleplayer-constraints (constraint-topics) +(defun get-roleplayer-constraints (constraint-topics &key (revision *TM-REVISION*)) "Returns a list of the form ((:role <topic> :player <topic> :card-min <string> :card-max <string>) <...>) which describes the cardinality of topctypes used as players in roles of given types in an association of a given type which is also the parent if this list." - (let ((applies-to (get-item-by-psi *applies-to-psi*)) - (constraint-role (get-item-by-psi *constraint-role-psi*)) - (topictype-role (get-item-by-psI *topictype-role-psi*)) - (roletype-role (get-item-by-psi *roletype-role-psi*)) - (roletype (get-item-by-psi *roletype-psi*)) - (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*)) - (topictype (get-item-by-psi *topictype-psi*)) - (topictype-constraint (is-type-constrained))) + (declare (type (or integer null) revision) + (list constraint-topics)) + (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (topictype-role (get-item-by-psI *topictype-role-psi* :revision revision)) + (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision)) + (roletype (get-item-by-psi *roletype-psi* :revision revision)) + (roletype-constraint (is-type-constrained :what *roletype-constraint-psi* + :revision revision)) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (is-type-constrained :revision revision))) (let ((roleplayer-constraints (loop for constraint-topic in constraint-topics append (let ((constraint-list - (get-constraint-topic-values constraint-topic))) + (get-constraint-topic-values constraint-topic + :revision revision))) (let ((players - (loop for role in (player-in-roles constraint-topic) - when (and (eq constraint-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (eq topictype-role (instance-of other-role)) - collect (player other-role)))) + (loop for role in (player-in-roles constraint-topic + :revision revision) + when (and (eq constraint-role + (instance-of role :revision revision)) + (eq applies-to + (instance-of + (parent role :revision revision) + :revision revision))) + append (loop for other-role in + (roles (parent role :revision revision) + :revision revision) + when (eq topictype-role + (instance-of other-role + :revision revision)) + collect (player other-role + :revision revision)))) (roles - (loop for role in (player-in-roles constraint-topic) - when (and (eq constraint-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) + (loop for role in (player-in-roles constraint-topic + :revision revision) + when (and (eq constraint-role + (instance-of role :revision revision)) + (eq applies-to + (instance-of + (parent role :revision revision) + :revision revision))) append (loop for other-role in (roles (parent role)) - when (eq roletype-role (instance-of other-role)) + when (eq roletype-role + (instance-of other-role + :revision revision)) collect (player other-role))))) (when (or (and players (not roles)) (and roles (not players))) (error "roleplayer-constraint ~a is not complete:~%players: ~a~%roles: ~a~%" - (uri (first (psis constraint-topic))) - (map 'list #'(lambda(x)(uri (first (psis x)))) players) - (map 'list #'(lambda(x)(uri (first (psis x)))) roles))) + (uri (first (psis constraint-topic + :revision revision))) + (map 'list + #'(lambda(x) + (uri (first (psis x :revision revision)))) + players) + (map 'list + #'(lambda(x) + (uri (first (psis x :revision revision)))) + roles))) (let ((cross-product (loop for player in players append (loop for role in roles - collect (list :player player :role role :constraint constraint-list))))) + collect + (list :player player + :role role + :constraint constraint-list))))) cross-product)))))) - (let ((role-player-tupples (remove-duplicates (loop for roleplayer-constraint in roleplayer-constraints collect (let ((current-player (getf roleplayer-constraint :player)) (current-role (getf roleplayer-constraint :role))) - (topictype-p current-player) - (topictype-p current-role roletype roletype-constraint) + (topictype-p current-player topictype topictype-constraint + nil revision) + (topictype-p current-role roletype roletype-constraint + nil revision) (list :player current-player :role current-role))) :test #'(lambda(x y) @@ -580,109 +426,163 @@ do (let ((constraint-lists (remove-duplicate-constraints (loop for roleplayer-constraint in roleplayer-constraints - when (and (eq (getf roleplayer-constraint :player) (getf role-player-tupple :player)) - (eq (getf roleplayer-constraint :role) (getf role-player-tupple :role))) + when (and (eq (getf roleplayer-constraint :player) + (getf role-player-tupple :player)) + (eq (getf roleplayer-constraint :role) + (getf role-player-tupple :role))) collect (getf roleplayer-constraint :constraint))))) (when (> (length constraint-lists) 1) (error "found contrary roleplayer-constraints:~%role: ~a~%player: ~a~% ~a ~%" - (uri (first (psis (getf role-player-tupple :role)))) - (uri (first (psis (getf role-player-tupple :player)))) + (uri (first (psis (getf role-player-tupple :role) + :revision revision))) + (uri (first (psis (getf role-player-tupple :player) + :revision revision))) constraint-lists)) (let ((json-player-type - (concatenate 'string "\"playerType\":" - (topics-to-json-list (getf (list-subtypes (getf role-player-tupple :player) nil nil) :subtypes)))) + (concatenate + 'string "\"playerType\":" + (topics-to-json-list + (getf (list-subtypes (getf role-player-tupple :player) + nil nil nil nil revision) :subtypes) + :revision revision))) (json-players - (concatenate 'string "\"players\":" - (topics-to-json-list - (list-instances (getf role-player-tupple :player) topictype topictype-constraint)))) + (concatenate + 'string "\"players\":" + (topics-to-json-list + (list-instances (getf role-player-tupple :player) + topictype topictype-constraint revision) + :revision revision))) (json-role - (concatenate 'string "\"roleType\":" - (topics-to-json-list - (getf (list-subtypes (getf role-player-tupple :role) roletype roletype-constraint) :subtypes)))) + (concatenate + 'string "\"roleType\":" + (topics-to-json-list + (getf (list-subtypes (getf role-player-tupple :role) + roletype roletype-constraint nil + nil revision) + :subtypes) + :revision revision))) (card-min - (concatenate 'string "\"cardMin\":" (getf (first constraint-lists) :card-min))) + (concatenate + 'string "\"cardMin\":" + (getf (first constraint-lists) :card-min))) (card-max - (concatenate 'string "\"cardMax\":" (getf (first constraint-lists) :card-max)))) + (concatenate + 'string "\"cardMax\":" + (getf (first constraint-lists) :card-max)))) (setf cleaned-roleplayer-constraints (concatenate 'string cleaned-roleplayer-constraints - "{" json-player-type "," json-players "," json-role "," card-min "," card-max "},"))))) + "{" json-player-type "," json-players "," + json-role "," card-min "," card-max "},"))))) (if (string= cleaned-roleplayer-constraints "[") (setf cleaned-roleplayer-constraints "null") (setf cleaned-roleplayer-constraints - (concatenate 'string (subseq cleaned-roleplayer-constraints 0 (- (length cleaned-roleplayer-constraints) 1)) "]"))) + (concatenate + 'string (subseq cleaned-roleplayer-constraints 0 + (- (length cleaned-roleplayer-constraints) 1)) + "]"))) cleaned-roleplayer-constraints))))) -(defun get-associationrole-constraints (constraint-topics) +(defun get-associationrole-constraints (constraint-topics &key + (revision *TM-REVISION*)) "Returns a list of the form ((:associationroletype <topic> :card-min <string> :card-max <string>), <...>) which describes all associationrole-constraints of the passed constraint-topics. - If as-json is set to t the return value of this function is a json-string otherwise a - list of lists of the following form (:roletype <topic, topic, ...> :cardMin <min> :cardMax <max>)" - (let ((applies-to (get-item-by-psi *applies-to-psi*)) - (roletype-role (get-item-by-psi *roletype-role-psi*)) - (constraint-role (get-item-by-psi *constraint-role-psi*)) - (roletype (get-item-by-psi *roletype-psi*)) - (roletype-constraint (is-type-constrained :what *roletype-constraint-psi*))) + If as-json is set to t the return value of this function is a + json-string otherwise a list of lists of the following form + (:roletype <topic, topic, ...> :cardMin <min> :cardMax <max>)" + (declare (type (or integer null) revision) + (list constraint-topics)) + (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (roletype-role (get-item-by-psi *roletype-role-psi* :revision revision)) + (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (roletype (get-item-by-psi *roletype-psi* :revision revision)) + (roletype-constraint (is-type-constrained :what *roletype-constraint-psi* + :revision revision))) (let ((associationrole-constraints (loop for constraint-topic in constraint-topics append (let ((constraint-list - (get-constraint-topic-values constraint-topic))) - (loop for role in (player-in-roles constraint-topic) - when (and (eq constraint-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (eq roletype-role (instance-of other-role)) - collect (list :associationroletype (player other-role) - :constraint constraint-list))))))) + (get-constraint-topic-values constraint-topic + :revision revision))) + (loop for role in (player-in-roles constraint-topic + :revision revision) + when (and (eq constraint-role + (instance-of role :revision revision)) + (eq applies-to + (instance-of (parent role :revision revision) + :revision revision))) + append (loop for other-role in + (roles (parent role :revision revision) + :revision revision) + when (eq roletype-role + (instance-of other-role + :revision revision)) + collect + (list :associationroletype + (player other-role :revision revision) + :constraint constraint-list))))))) (let ((associationroletype-topics - (remove-duplicates (map 'list #'(lambda(x) - (let ((associationroletype (getf x :associationroletype))) - (topictype-p associationroletype roletype roletype-constraint) - associationroletype)) - associationrole-constraints)))) + (remove-duplicates + (map 'list #'(lambda(x) + (let ((associationroletype (getf x :associationroletype))) + (topictype-p associationroletype roletype + roletype-constraint nil revision) + associationroletype)) + associationrole-constraints)))) (let ((cleaned-associationrole-constraints "[")) - ;(raw-constraints nil)) (loop for associationroletype-topic in associationroletype-topics - do (let ((constraint-lists - (remove-duplicate-constraints - (loop for associationrole-constraint in associationrole-constraints - when (eq associationroletype-topic (getf associationrole-constraint :associationroletype)) - collect (getf associationrole-constraint :constraint))))) - (when (> (length constraint-lists) 1) - (error "found contrary associationrole-constraints: ~a ~a~%" (uri (first (psis associationroletype-topic))) constraint-lists)) + do + (let ((constraint-lists + (remove-duplicate-constraints + (loop for associationrole-constraint in + associationrole-constraints + when (eq associationroletype-topic + (getf associationrole-constraint + :associationroletype)) + collect (getf associationrole-constraint :constraint))))) + (when (> (length constraint-lists) 1) + (error "found contrary associationrole-constraints: ~a ~a~%" (uri (first (psis associationroletype-topic :revision revision))) constraint-lists)) (let ((roletype-with-subtypes (json:encode-json-to-string (map 'list #'(lambda(topic) - (map 'list #'uri (psis topic))) - (getf (list-subtypes associationroletype-topic roletype roletype-constraint) :subtypes))))) - (setf cleaned-associationrole-constraints - (concatenate 'string - cleaned-associationrole-constraints - "{\"roleType\":" roletype-with-subtypes - ",\"cardMin\":" (getf (first constraint-lists) :card-min) - ",\"cardMax\":" (getf (first constraint-lists) :card-max) "},"))))) - - + (map 'list #'uri + (psis topic :revision revision))) + (getf (list-subtypes associationroletype-topic + roletype roletype-constraint + nil nil revision) :subtypes))))) + (setf cleaned-associationrole-constraints + (concatenate 'string + cleaned-associationrole-constraints + "{\"roleType\":" roletype-with-subtypes + ",\"cardMin\":" (getf (first constraint-lists) + :card-min) + ",\"cardMax\":" (getf (first constraint-lists) + :card-max) "},"))))) (if (string= cleaned-associationrole-constraints "[") (setf cleaned-associationrole-constraints "null") (setf cleaned-associationrole-constraints - (concatenate 'string (subseq cleaned-associationrole-constraints 0 (- (length cleaned-associationrole-constraints) 1)) "]"))) + (concatenate + 'string (subseq cleaned-associationrole-constraints 0 + (- (length cleaned-associationrole-constraints) + 1)) "]"))) cleaned-associationrole-constraints))))) ;; ============================================================================= ;; --- all topic constraints --------------------------------------------------- ;; ============================================================================= -(defun get-constraints-of-topic (topic-instances &key(treat-as 'type)) +(defun get-constraints-of-topic (topic-instances &key(treat-as 'type) + (revision *TM-REVISION*)) "Returns a constraint list with the constraints: subjectidentifier-constraints, subjectlocator-constraints, topicname-constraints, topicoccurrence-constraints and uniqueoccurrence-constraints. topic-instances should be a list with exactly one item if trea-as is set to type otherwise it can constain more items." - (declare (list topic-instances)) + (declare (list topic-instances) + (symbol treat-as) + (type (or integer null) revision)) (when (and (> (length topic-instances) 1) (not (eql treat-as 'type))) (error "From get-constraints-of-topic: topic-instances must contain exactly one item when treated as instance!")) @@ -695,14 +595,17 @@ (uniqueoccurrence-constraints nil)) (loop for topic-instance in topic-instances do (let ((current-constraints - (get-all-constraint-topics-of-topic topic-instance :treat-as treat-as))) + (get-all-constraint-topics-of-topic topic-instance + :treat-as treat-as + :revision revision))) (dolist (item (getf current-constraints :abstract-topictype-constraints)) (pushnew item abstract-topictype-constraints)) (dolist (item (getf current-constraints :exclusive-instance-constraints)) (let ((current-list (list topic-instance (list item)))) (let ((found-item - (find current-list exclusive-instance-constraints :key #'first))) + (find current-list exclusive-instance-constraints + :key #'first))) (if found-item (dolist (inner-item (second current-list)) (pushnew inner-item (second found-item))) @@ -720,28 +623,41 @@ (let ((exclusive-instance-constraints (let ((value "[")) (loop for exclusive-instance-constraint in exclusive-instance-constraints - do (setf value (concatenate 'string value - (get-exclusive-instance-constraints (first exclusive-instance-constraint) - (second exclusive-instance-constraint)) ","))) + do (setf value + (concatenate 'string value + (get-exclusive-instance-constraints + (first exclusive-instance-constraint) + (second exclusive-instance-constraint) + :revision revision) ","))) (if (string= value "[") (setf value "null") - (setf value (concatenate 'string (subseq value 0 (- (length value) 1)) "]"))) + (setf value (concatenate 'string (subseq value 0 + (- (length value) 1)) "]"))) (concatenate 'string "\"exclusiveInstances\":" value))) (subjectidentifier-constraints (let ((value - (get-simple-constraints subjectidentifier-constraints :error-msg-constraint-name "subjectidentifier"))) + (get-simple-constraints + subjectidentifier-constraints + :error-msg-constraint-name "subjectidentifier" + :revision revision))) (concatenate 'string "\"subjectIdentifierConstraints\":" value))) (subjectlocator-constraints (let ((value - (get-simple-constraints subjectlocator-constraints :error-msg-constraint-name "subjectlocator"))) + (get-simple-constraints + subjectlocator-constraints + :error-msg-constraint-name "subjectlocator" + :revision revision))) (concatenate 'string "\"subjectLocatorConstraints\":" value))) (topicname-constraints (let ((value - (get-topicname-constraints topicname-constraints))) + (get-topicname-constraints topicname-constraints + :revision revision))) (concatenate 'string "\"topicNameConstraints\":" value))) (topicoccurrence-constraints (let ((value - (get-topicoccurrence-constraints topicoccurrence-constraints uniqueoccurrence-constraints))) + (get-topicoccurrence-constraints topicoccurrence-constraints + uniqueoccurrence-constraints + :revision revision))) (concatenate 'string "\"topicOccurrenceConstraints\":" value))) (abstract-constraint (concatenate 'string "\"abstractConstraint\":" @@ -749,54 +665,89 @@ "true" "false")))) (let ((json-string - (concatenate 'string "{" exclusive-instance-constraints "," subjectidentifier-constraints + (concatenate 'string "{" exclusive-instance-constraints "," + subjectidentifier-constraints "," subjectlocator-constraints "," topicname-constraints "," topicoccurrence-constraints "," abstract-constraint "}"))) json-string)))) -(defun get-exclusive-instance-constraints(owner exclusive-instances-lists) +(defun get-exclusive-instance-constraints(owner exclusive-instances-lists + &key (revision *TM-REVISION*)) "Returns a JSON-obejct of the following form: {owner: [psi-1, psi-2], exclusives: [[psi-1-1, psi-1-2], [psi-2-1, <...>], <...>]}." - (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (topictype-role (get-item-by-psi *topictype-role-psi*)) - (topictype (get-item-by-psi *topictype-psi*)) - (topictype-constraint (is-type-constrained))) + (declare (type (or integer null) revision)) + (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (is-type-constrained :revision revision))) (let ((topics (remove-duplicates (loop for exclusive-instances-list in exclusive-instances-lists - append (let ((owner (getf exclusive-instances-list :owner)) - (exclusive-constraints (getf exclusive-instances-list :exclusive-constraints))) - (loop for exclusive-constraint in exclusive-constraints - append (loop for role in (player-in-roles exclusive-constraint) - when (and (eq constraint-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (and (eq topictype-role (instance-of other-role)) - (not (eq owner (player other-role)))) - ;collect (player other-role))))))))) - append (getf (list-subtypes (player other-role) topictype topictype-constraint) :subtypes))))))))) - (concatenate 'string "{\"owner\":" (json-exporter::identifiers-to-json-string owner) + append + (let ((owner (getf exclusive-instances-list :owner)) + (exclusive-constraints + (getf exclusive-instances-list :exclusive-constraints))) + (loop for exclusive-constraint in exclusive-constraints + append + (loop for role in + (player-in-roles exclusive-constraint + :revision revision) + when (and (eq constraint-role + (instance-of role + :revision revision)) + (eq applies-to (instance-of + (parent role :revision revision) + :revision revision))) + append + (loop for other-role in + (roles + (parent role :revision revision) + :revision revision) + when (and (eq topictype-role + (instance-of other-role + :revision revision)) + (not + (eq owner (player other-role + :revision revision)))) + append + (getf + (list-subtypes + (player other-role :revision revision) + topictype topictype-constraint nil + nil revision) :subtypes))))))))) + (concatenate 'string "{\"owner\":" (json-exporter::identifiers-to-json-string + owner :revision revision) ",\"exclusives\":" - (json:encode-json-to-string (map 'list #'(lambda(y) - (map 'list #'uri y)) - (map 'list #'psis topics))) "}")))) + (json:encode-json-to-string + (map 'list #'(lambda(y) + (map 'list #'uri y)) + (map 'list #'(lambda(z) + (psis z :revision revision)) + topics))) "}")))) -(defun get-simple-constraints(constraint-topics &key (error-msg-constraint-name "uniqueoccurrence")) +(defun get-simple-constraints(constraint-topics &key + (error-msg-constraint-name "uniqueoccurrence") + (revision *TM-REVISION*)) "Returns a list of the form ((:regexp <string> :card-min <string> :card-max <string>)) which contains the subjectidentifier, subjectlocator or unique-occurrence constraints. This depends on the passed constraint-topics." + (declare (list constraint-topics) + (string error-msg-constraint-name) + (type (or integer null) revision)) (let ((all-values (remove-duplicate-constraints (loop for constraint-topic in constraint-topics - collect (get-constraint-topic-values constraint-topic))))) + collect (get-constraint-topic-values constraint-topic + :revision revision))))) (let ((contrary-constraints (find-contrary-constraints all-values))) (when contrary-constraints - (error "found contrary ~a-constraints: ~a~%" error-msg-constraint-name contrary-constraints))) + (error "found contrary ~a-constraints: ~a~%" + error-msg-constraint-name contrary-constraints))) (simple-constraints-to-json all-values))) @@ -807,13 +758,15 @@ [{regexp: expr, cardMin: 123, cardMax: 456}, <...>]." (let ((constraints "[")) (loop for constraint in simple-constraints - do (let ((constraint (concatenate 'string "{\"regexp\":" - (json:encode-json-to-string (getf constraint :regexp)) - ",\"cardMin\":" - (json:encode-json-to-string (getf constraint :card-min)) - ",\"cardMax\":" - (json:encode-json-to-string (getf constraint :card-max)) - "}"))) + do (let ((constraint + (concatenate + 'string "{\"regexp\":" + (json:encode-json-to-string (getf constraint :regexp)) + ",\"cardMin\":" + (json:encode-json-to-string (getf constraint :card-min)) + ",\"cardMax\":" + (json:encode-json-to-string (getf constraint :card-max)) + "}"))) (if (string= constraints "[") (setf constraints (concatenate 'string constraints constraint)) (setf constraints (concatenate 'string constraints "," constraint))))) @@ -823,34 +776,53 @@ constraints)) -(defun get-topicname-constraints(constraint-topics) +(defun get-topicname-constraints(constraint-topics &key (revision *TM-REVISION*)) "Returns all topicname constraints as a list of the following form: [{nametypescopes:[{nameType: [psi-1, psi-2], scopeConstraints: [<scopeConstraint>]}, {nameType: [subtype-1-psi-1], scopeConstraints: [<scopeConstraints>]}, constraints: [<simpleConstraint>, <...>]}, <...>]." - (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (nametype-role (get-item-by-psi *nametype-role-psi*)) - (nametype (get-item-by-psi *nametype-psi*)) - (nametype-constraint (is-type-constrained :what *nametype-constraint-psi*))) + (declare (type (or integer null) revision) + (list constraint-topics)) + (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (nametype-role (get-item-by-psi *nametype-role-psi* :revision revision)) + (nametype (get-item-by-psi *nametype-psi* :revision revision)) + (nametype-constraint (is-type-constrained :what *nametype-constraint-psi* + :revision revision))) (let ((topicname-constraints - (remove-if #'null - (loop for constraint-topic in constraint-topics - append (loop for role in (player-in-roles constraint-topic) - when (and (eq constraint-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (eq nametype-role (instance-of other-role)) - collect (let ((nametype-topic (player other-role)) - (constraint-list (get-constraint-topic-values constraint-topic))) - (list :type nametype-topic :constraint constraint-list)))))))) + (remove-if + #'null + (loop for constraint-topic in constraint-topics + append + (loop for role in (player-in-roles constraint-topic + :revision revision) + when (and (eq constraint-role + (instance-of role :revision revision)) + (eq applies-to + (instance-of (parent role :revision revision) + :revision revision))) + append + (loop for other-role in + (roles (parent role :revision revision) + :revision revision) + when (eq nametype-role + (instance-of other-role :revision revision)) + collect + (let ((nametype-topic + (player other-role :revision revision)) + (constraint-list + (get-constraint-topic-values constraint-topic + :revision revision))) + (list :type nametype-topic + :constraint constraint-list)))))))) (let ((nametype-topics (remove-duplicates (map 'list #'(lambda(x) (let ((topicname-type (getf x :type))) - (topictype-p topicname-type nametype nametype-constraint) + (topictype-p topicname-type nametype + nametype-constraint nil revision) topicname-type)) topicname-constraints)))) (let ((cleaned-topicname-constraints "[")) @@ -863,31 +835,55 @@ (let ((contrary-constraints (find-contrary-constraints constraint-lists))) (when contrary-constraints - (error "found contrary topicname-constraints: ~a~%" contrary-constraints))) + (error "found contrary topicname-constraints: ~a~%" + contrary-constraints))) (let ((nametype-with-subtypes - (remove-if #'null (getf (list-subtypes nametype-topic nametype nametype-constraint) :subtypes)))) + (remove-if + #'null + (getf (list-subtypes nametype-topic nametype + nametype-constraint nil nil revision) + :subtypes)))) (let ((nametypescopes "\"nametypescopes\":[")) (loop for current-topic in nametype-with-subtypes do (let ((current-json-string - (concatenate 'string "{\"nameType\":" (json-exporter::identifiers-to-json-string current-topic) - ",\"scopeConstraints\":" (get-typescope-constraints current-topic :what 'topicname) "}"))) - (setf nametypescopes (concatenate 'string nametypescopes current-json-string ",")))) + (concatenate + 'string "{\"nameType\":" + (json-exporter::identifiers-to-json-string + current-topic :revision revision) + ",\"scopeConstraints\":" + (get-typescope-constraints current-topic + :what 'topicname + :revision revision) + "}"))) + (setf nametypescopes + (concatenate 'string nametypescopes + current-json-string ",")))) (if (string= nametypescopes "\"nametypescopes\"[") (setf nametypescopes "null") (setf nametypescopes - (concatenate 'string (subseq nametypescopes 0 (- (length nametypescopes) 1)) "]"))) + (concatenate + 'string (subseq nametypescopes 0 + (- (length nametypescopes) 1)) "]"))) (let ((json-constraint-lists - (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists)))) + (concatenate + 'string "\"constraints\":" + (simple-constraints-to-json constraint-lists)))) (setf cleaned-topicname-constraints - (concatenate 'string cleaned-topicname-constraints "{" nametypescopes "," json-constraint-lists "},"))))))) + (concatenate + 'string cleaned-topicname-constraints "{" + nametypescopes "," json-constraint-lists "},"))))))) (if (string= cleaned-topicname-constraints "[") (setf cleaned-topicname-constraints "null") (setf cleaned-topicname-constraints - (concatenate 'string (subseq cleaned-topicname-constraints 0 (- (length cleaned-topicname-constraints) 1)) "]"))) + (concatenate + 'string (subseq cleaned-topicname-constraints 0 + (- (length cleaned-topicname-constraints) 1)) + "]"))) cleaned-topicname-constraints))))) -(defun get-topicoccurrence-constraints(constraint-topics unique-constraint-topics) +(defun get-topicoccurrence-constraints(constraint-topics unique-constraint-topics + &key (revision *TM-REVISION*)) "Returns all topicoccurrence constraints as a list of the following form: [{occurrenceTypes:[{occurrenceType:[psi-1,psi-2], scopeConstraints:[<scopeConstraints>], @@ -896,105 +892,177 @@ constraints:[<simpleConstraints>, <...>], uniqueConstraint:[<uniqueConstraints>, <...> ]} <...>]." - (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi*)) - (occurrencetype (get-item-by-psi *occurrencetype-psi*)) - (occurrencetype-constraint (is-type-constrained :what *occurrencetype-constraint-psi*))) + (declare (type (or integer null) revision) + (list constraint-topics unique-constraint-topics)) + (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi* + :revision revision)) + (occurrencetype (get-item-by-psi *occurrencetype-psi* + :revision revision)) + (occurrencetype-constraint + (is-type-constrained :what *occurrencetype-constraint-psi* + :revision revision))) (let ((topicoccurrence-constraints - (remove-if #'null - (loop for constraint-topic in constraint-topics - append (loop for role in (player-in-roles constraint-topic) - when (and (eq constraint-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (eq occurrencetype-role (instance-of other-role)) - collect (let ((occurrencetype-topic (player other-role)) - (constraint-list (get-constraint-topic-values constraint-topic))) - (list :type occurrencetype-topic :constraint constraint-list)))))))) + (remove-if + #'null + (loop for constraint-topic in constraint-topics + append + (loop for role in (player-in-roles constraint-topic + :revision revision) + when (and (eq constraint-role + (instance-of role :revision revision)) + (eq applies-to + (instance-of (parent role :revision revision) + :revision revision))) + append + (loop for other-role in (roles (parent role :revision revision) + :revision revision) + when (eq occurrencetype-role + (instance-of other-role :revision revision)) + collect + (let ((occurrencetype-topic + (player other-role :revision revision)) + (constraint-list + (get-constraint-topic-values constraint-topic + :revision revision))) + (list :type occurrencetype-topic + :constraint constraint-list)))))))) (let ((occurrencetype-topics (remove-duplicates - (map 'list #'(lambda(x) - (let ((occurrence-type (getf x :type))) - (topictype-p occurrence-type occurrencetype occurrencetype-constraint) - occurrence-type)) + (map 'list + #'(lambda(x) + (let ((occurrence-type (getf x :type))) + (topictype-p occurrence-type occurrencetype + occurrencetype-constraint nil revision) + occurrence-type)) topicoccurrence-constraints)))) (let ((cleaned-topicoccurrence-constraints "[")) (loop for occurrencetype-topic in occurrencetype-topics do (let ((constraint-lists (remove-duplicate-constraints - (loop for topicoccurrence-constraint in topicoccurrence-constraints - when (eq occurrencetype-topic (getf topicoccurrence-constraint :type)) + (loop for topicoccurrence-constraint in + topicoccurrence-constraints + when (eq occurrencetype-topic + (getf topicoccurrence-constraint :type)) collect (getf topicoccurrence-constraint :constraint))))) (let ((contrary-constraints (find-contrary-constraints constraint-lists))) (when contrary-constraints - (error "found contrary topicname-constraints: ~a~%" contrary-constraints))) - - + (error "found contrary topicname-constraints: ~a~%" + contrary-constraints))) (let ((occurrencetype-with-subtypes - (getf (list-subtypes occurrencetype-topic occurrencetype occurrencetype-constraint) :subtypes))) - + (getf + (list-subtypes occurrencetype-topic + occurrencetype occurrencetype-constraint + nil nil revision) :subtypes))) (let ((occurrencetypes-json-string "\"occurrenceTypes\":[")) (loop for current-topic in occurrencetype-with-subtypes do (let ((current-json-string - (concatenate 'string "{\"occurrenceType\":" (json-exporter::identifiers-to-json-string current-topic) - ",\"scopeConstraints\":" (get-typescope-constraints current-topic :what 'topicoccurrence) - ",\"datatypeConstraint\":" (get-occurrence-datatype-constraint current-topic) "}"))) - (setf occurrencetypes-json-string (concatenate 'string occurrencetypes-json-string current-json-string ",")))) - + (concatenate + 'string "{\"occurrenceType\":" + (json-exporter::identifiers-to-json-string + current-topic :revision revision) + ",\"scopeConstraints\":" + (get-typescope-constraints + current-topic :what 'topicoccurrence + :revision revision) + ",\"datatypeConstraint\":" + (get-occurrence-datatype-constraint + current-topic :revision revision) + "}"))) + (setf occurrencetypes-json-string + (concatenate 'string occurrencetypes-json-string + current-json-string ",")))) (if (string= occurrencetypes-json-string "\"occurrenceTypes\"[") (setf occurrencetypes-json-string "null") (setf occurrencetypes-json-string - (concatenate 'string (subseq occurrencetypes-json-string 0 (- (length occurrencetypes-json-string) 1)) "]"))) + (concatenate + 'string (subseq occurrencetypes-json-string 0 + (- (length + occurrencetypes-json-string) 1)) + "]"))) (let ((unique-constraints (concatenate 'string "\"uniqueConstraints\":" - (get-simple-constraints unique-constraint-topics))) + (get-simple-constraints + unique-constraint-topics + :revision revision))) (json-constraint-lists - (concatenate 'string "\"constraints\":" (simple-constraints-to-json constraint-lists)))) + (concatenate + 'string "\"constraints\":" + (simple-constraints-to-json constraint-lists)))) (let ((current-json-string - (concatenate 'string "{" occurrencetypes-json-string "," json-constraint-lists "," unique-constraints "}"))) + (concatenate + 'string "{" occurrencetypes-json-string "," + json-constraint-lists "," unique-constraints "}"))) (setf cleaned-topicoccurrence-constraints - (concatenate 'string cleaned-topicoccurrence-constraints current-json-string ",")))))))) + (concatenate + 'string cleaned-topicoccurrence-constraints + current-json-string ",")))))))) (if (string= cleaned-topicoccurrence-constraints "[") (setf cleaned-topicoccurrence-constraints "null") (setf cleaned-topicoccurrence-constraints - (concatenate 'string (subseq cleaned-topicoccurrence-constraints 0 (- (length cleaned-topicoccurrence-constraints) 1)) "]"))) + (concatenate + 'string + (subseq + cleaned-topicoccurrence-constraints 0 + (- (length cleaned-topicoccurrence-constraints) 1)) "]"))) cleaned-topicoccurrence-constraints))))) -(defun get-occurrence-datatype-constraint(occurrencetype-topic) +(defun get-occurrence-datatype-constraint(occurrencetype-topic + &key (revision *TM-REVISION*)) "Return a datatype qualifier as a string." - (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi*)) - (datatype (get-item-by-psi *datatype-psi*)) - (occurrencedatatype-constraint (get-item-by-psi *occurrencedatatype-constraint-psi*))) + (declare (TopicC occurrencetype-topic) + (type (or integer null) revision)) + (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (occurrencetype-role (get-item-by-psi *occurrencetype-role-psi* + :revision revision)) + (datatype (get-item-by-psi *datatype-psi* :revision revision)) + (occurrencedatatype-constraint + (get-item-by-psi *occurrencedatatype-constraint-psi* + :revision revision)) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (get-item-by-psi *topictype-constraint-psi* + :revision revision))) (let ((datatype-constraints (remove-duplicates - (loop for role in (player-in-roles occurrencetype-topic) - when (and (eq occurrencetype-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (and (eq constraint-role (instance-of other-role)) - (topictype-of-p (player other-role) occurrencedatatype-constraint)) - collect (player other-role)))))) + (loop for role in (player-in-roles occurrencetype-topic :revision revision) + when (and (eq occurrencetype-role (instance-of role :revision revision)) + (eq applies-to (instance-of (parent role :revision revision) + :revision revision))) + append (loop for other-role in (roles (parent role :revision revision) + :revision revision) + when (and (eq constraint-role + (instance-of other-role :revision revision)) + (topictype-of-p + (player other-role :revision revision) + occurrencedatatype-constraint topictype + topictype-constraint nil revision)) + collect (player other-role :revision revision)))))) (let ((datatype-constraint (remove-duplicates - (map 'list #'(lambda(constraint-topic) - (loop for occurrence in (occurrences constraint-topic) - when (and (eq (instance-of occurrence) datatype) - (slot-boundp occurrence 'charvalue)) - return (charvalue occurrence))) - datatype-constraints)))) + (map + 'list + #'(lambda(constraint-topic) + (loop for occurrence in + (occurrences constraint-topic :revision revision) + when (and (eq (instance-of occurrence :revision revision) + datatype) + (slot-boundp occurrence 'charvalue)) + return (charvalue occurrence))) + datatype-constraints)))) (when (> (length datatype-constraint) 1) - (error "found contrary occurrence-datatype-constraints: ~a~%" datatype-constraints)) + (error "found contrary occurrence-datatype-constraints: ~a~%" + datatype-constraints)) (if datatype-constraint (json:encode-json-to-string (first datatype-constraint)) "null"))))) -(defun get-typescope-constraints(element-type-topic &key(what 'topicname)) +(defun get-typescope-constraints(element-type-topic &key (what 'topicname) + (revision *TM-REVISION*)) "Returns a list of scopes for the element-typetopic which is the type topic of a topicname, a topicoccurrence or an association. To specifiy of what kind of element the scopes should be there is the key-variable what. @@ -1003,116 +1071,175 @@ [{scopeTypes:[[[psi-1-1, psi-1-2], [subtype-1-psi-1, subtype-1-psi-2]], [[psi-2-1], [subtype-1-psi-1], [subtype-2-psi-1]]], cardMin: <int-as-string>, cardMax <int-as-string | MAX_INT>}, <...>]." + (declare (TopicC element-type-topic) + (symbol what) + (type (or integer null) revision)) (let ((element-type-role-and-scope-constraint (cond ((eq what 'topicname) - (list (get-item-by-psi *nametype-role-psi*) - (get-item-by-psi *nametypescope-constraint-psi*))) + (list (get-item-by-psi *nametype-role-psi* :revision revision) + (get-item-by-psi *nametypescope-constraint-psi* + :revision revision))) ((eq what 'topicoccurrence) (list - (get-item-by-psi *occurrencetype-role-psi*) - (get-item-by-psi *occurrencetypescope-constraint-psi*))) + (get-item-by-psi *occurrencetype-role-psi* :revision revision) + (get-item-by-psi *occurrencetypescope-constraint-psi* + :revision revision))) ((eq what 'association) (list - (get-item-by-psi *associationtype-role-psi*) - (get-item-by-psi *associationtypescope-constraint-psi*))))) - (scopetype-role (get-item-by-psi *scopetype-role-psi*)) - (constraint-role (get-item-by-psi *constraint-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (scopetype (get-item-by-psi *scopetype-psi*))) + (get-item-by-psi *associationtype-role-psi* :revision revision) + (get-item-by-psi *associationtypescope-constraint-psi* + :revision revision))))) + (scopetype-role (get-item-by-psi *scopetype-role-psi* :revision revision)) + (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (scopetype (get-item-by-psi *scopetype-psi* :revision revision)) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (get-item-by-psi *topictype-constraint-psi* + :revision revision))) (when (and (= (length element-type-role-and-scope-constraint) 2) (first element-type-role-and-scope-constraint) (second element-type-role-and-scope-constraint)) (let ((type-role (first element-type-role-and-scope-constraint)) (typescope-constraint (second element-type-role-and-scope-constraint))) (let ((typescope-constraints - (loop for role in (player-in-roles element-type-topic) - when (and (eq type-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (and (eq constraint-role (instance-of other-role)) - (topictype-of-p (player other-role) typescope-constraint)) - collect (let ((scopes nil) - (constraint nil)) - (loop for c-role in (player-in-roles (player other-role)) - when (and (eq constraint-role (instance-of c-role)) - (eq applies-to (instance-of (parent c-role)))) - do (progn - (setf constraint (get-constraint-topic-values (player c-role))) - (loop for c-other-role in (roles (parent c-role)) - when (eq scopetype-role (instance-of c-other-role)) - do (push (player c-other-role) scopes)))) - (list :scopes scopes :constraint constraint)))))) + (loop for role in + (player-in-roles element-type-topic :revision revision) + when (and (eq type-role (instance-of role :revision revision)) + (eq applies-to + (instance-of (parent role :revision revision) + :revision revision))) + append + (loop for other-role in + (roles (parent role :revision revision) + :revision revision) + when (and (eq constraint-role + (instance-of other-role :revision revision)) + (topictype-of-p + (player other-role :revision revision) + typescope-constraint topictype + topictype-constraint nil revision)) + collect + (let ((scopes nil) + (constraint nil)) + (loop for c-role in + (player-in-roles + (player other-role :revision revision) + :revision revision) + when (and (eq constraint-role + (instance-of c-role :revision revision)) + (eq applies-to + (instance-of + (parent c-role :revision revision) + :revision revision))) + do (progn + (setf constraint + (get-constraint-topic-values + (player c-role :revision revision) + :revision revision)) + (loop for c-other-role in + (roles (parent c-role :revision revision) + :revision revision) + when (eq scopetype-role + (instance-of c-other-role + :revision revision)) + do (push + (player c-other-role :revision revision) + scopes)))) + (list :scopes scopes :constraint constraint)))))) (let ((scopetype-groups - (remove-duplicates (map 'list #'(lambda(x) - (let ((scopes (getf x :scopes))) - (when scopes - scopes))) - typescope-constraints) - :test #'(lambda(x y) - (when (and (= (length x) (length y)) - (= (length x) (length (intersection x y)))) - t))))) + (remove-duplicates + (map 'list #'(lambda(x) + (let ((scopes (getf x :scopes))) + (when scopes + scopes))) + typescope-constraints) + :test #'(lambda(x y) + (when (and (= (length x) (length y)) + (= (length x) (length (intersection x y)))) + t))))) (let ((cleaned-typescope-constraints "[")) (loop for scopetype-group in scopetype-groups do (let ((constraint-lists (remove-duplicate-constraints (loop for typescope-constraint in typescope-constraints - when (and (= (length (getf typescope-constraint :scopes)) - (length scopetype-group)) - (= (length (getf typescope-constraint :scopes)) - (length (intersection (getf typescope-constraint :scopes) scopetype-group)))) + when + (and (= (length (getf typescope-constraint :scopes)) + (length scopetype-group)) + (= (length (getf typescope-constraint :scopes)) + (length (intersection + (getf typescope-constraint :scopes) + scopetype-group)))) collect (getf typescope-constraint :constraint))))) (when (> (length constraint-lists) 1) (error "found contrary scopetype-constraints for ~a: ~a~%" - (map 'list #'(lambda(x)(uri (first (psis x)))) scopetype-group) + (map 'list + #'(lambda(x) + (uri (first (psis x :revision revision)))) + scopetype-group) constraint-lists)) (let ((card-min (getf (first constraint-lists) :card-min)) (card-max (getf (first constraint-lists) :card-max))) (let ((json-scopes - (concatenate 'string "\"scopeTypes\":" - - (let ((scopetypes-with-subtypes - (remove-if #'null - (loop for current-scopetype in scopetype-group - collect (getf (list-subtypes current-scopetype scopetype nil) :subtypes))))) - - (json:encode-json-to-string - (map 'list #'(lambda(topic-group) - (map 'list #'(lambda(topic) - (map 'list #'uri (psis topic))) - topic-group)) - scopetypes-with-subtypes)))))) + (concatenate + 'string "\"scopeTypes\":" + (let ((scopetypes-with-subtypes + (remove-if + #'null + (loop for current-scopetype in scopetype-group + collect (getf + (list-subtypes current-scopetype + scopetype nil nil + nil revision) + :subtypes))))) + (json:encode-json-to-string + (map + 'list + #'(lambda(topic-group) + (map 'list + #'(lambda(topic) + (map 'list #'uri + (psis topic :revision revision))) + topic-group)) + scopetypes-with-subtypes)))))) (let ((current-json-string - (concatenate 'string "{" json-scopes ",\"cardMin\":\"" card-min "\",\"cardMax\":\"" card-max "\"}"))) + (concatenate 'string "{" json-scopes + ",\"cardMin\":\"" card-min + "\",\"cardMax\":\"" card-max "\"}"))) (setf cleaned-typescope-constraints - (concatenate 'string cleaned-typescope-constraints current-json-string ","))))))) + (concatenate 'string cleaned-typescope-constraints + current-json-string ","))))))) (if (string= cleaned-typescope-constraints "[") (setf cleaned-typescope-constraints "null") (setf cleaned-typescope-constraints - (concatenate 'string (subseq cleaned-typescope-constraints 0 (- (length cleaned-typescope-constraints) 1)) "]"))) + (concatenate + 'string + (subseq cleaned-typescope-constraints 0 + (- (length cleaned-typescope-constraints) 1)) "]"))) cleaned-typescope-constraints))))))) ;; ============================================================================= ;; --- some basic helpers ------------------------------------------------------ ;; ============================================================================= -(defun get-constraint-topic-values(topic) +(defun get-constraint-topic-values(topic &key (revision *TM-REVISION*)) "Returns all constraint values of the passed topic in the following form (list :regexp regexp :card-min card-min :card-max card-max)" + (declare (type (or integer null) revision)) (let ((regexp - (get-constraint-occurrence-value topic)) + (get-constraint-occurrence-value topic :revision revision)) (card-min - (get-constraint-occurrence-value topic :what 'card-min)) + (get-constraint-occurrence-value topic :what 'card-min :revision revision)) (card-max - (get-constraint-occurrence-value topic :what 'card-max))) + (get-constraint-occurrence-value topic :what 'card-max :revision revision))) (when (and (string/= "MAX_INT" card-max) (> (parse-integer card-min) (parse-integer card-max))) (error "card-min (~a) must be < card-max (~a)" card-min card-max)) (list :regexp regexp :card-min card-min :card-max card-max))) -(defun get-constraint-occurrence-value(topic &key (what 'regexp)) +(defun get-constraint-occurrence-value(topic &key (what 'regexp) + (revision *TM-REVISION*)) "Checks the occurrence-value of a regexp, card-min or card-max constraint-occurrence. If what = 'regexp and the occurrence-value is empty there will be returned @@ -1121,6 +1248,9 @@ the value '0'. If what = 'card-max and the occurrence-value is empty there will be returned the value 'MAX_INT'" + (declare (type (or integer null) revision) + (TopicC topic) + (symbol what)) (let ((occurrence-type (get-item-by-psi (cond @@ -1131,11 +1261,14 @@ ((eq what 'card-max) *card-max-psi*) (t - ""))))) + "")) + :revision revision))) (when occurrence-type (let ((occurrence-value (let ((occurrence - (find occurrence-type (occurrences topic) :key #'instance-of))) + (find occurrence-type (occurrences topic :revision revision) + :key #'(lambda(occ) + (instance-of occ :revision revision))))) (if (and occurrence (slot-boundp occurrence 'charvalue) (> (length (charvalue occurrence)) 0)) @@ -1157,7 +1290,7 @@ (condition () nil)))) (unless is-valid (error "card-min in ~a is \"~a\" but should be >= 0" - (uri (first (psis topic))) + (uri (first (psis topic :revision revision))) occurrence-value)))) ((eq what 'card-max) (let ((is-valid @@ -1184,9 +1317,14 @@ do (progn (when (> (length current-constraint) 0) (return-from find-contrary-constraints current-constraint)) - (setf current-constraint (remove-if #'null (map 'list #'(lambda(x) - (contrary-constraint-list x constraint-list)) - constraint-lists))))))) + (setf current-constraint + (remove-if + #'null + (map 'list + #'(lambda(x) + (contrary-constraint-list x constraint-list)) + constraint-lists))))))) + (defun contrary-constraint-list (lst-1 lst-2) "Returns both passed lists when they have the same @@ -1208,7 +1346,6 @@ (remove-duplicates constraint-lists :test #'eql-constraint-list)) - (defun eql-constraint-list (lst-1 lst-2) "Compares two constraint lists of the form (list <string> <string> string>) or (list <topic> <string> <string> <string>." @@ -1220,20 +1357,35 @@ ;; --- gets all constraint topics ---------------------------------------------- -(defun get-direct-constraint-topics-of-topic (topic-instance) +(defun get-direct-constraint-topics-of-topic (topic-instance &key + (revision *TM-REVISION*)) "Returns all constraint topics defined for the passed topic-instance" - (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) - (topictype-role (get-item-by-psi *topictype-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (abstract-topictype-constraint (get-item-by-psi *abstract-topictype-constraint-psi*)) - (exclusive-instance-constraint (get-item-by-psi *exclusive-instance-psi*)) - (subjectidentifier-constraint (get-item-by-psi *subjectidentifier-constraint-psi*)) - (subjectlocator-constraint (get-item-by-psi *subjectlocator-constraint-psi*)) - (topicname-constraint (get-item-by-psi *topicname-constraint-psi*)) - (topicoccurrence-constraint (get-item-by-psi *topicoccurrence-constraint-psi*)) - (uniqueoccurrence-constraint (get-item-by-psi *uniqueoccurrence-constraint-psi*)) - (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*)) - (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*)) + (declare (type (or integer null) revision) + (TopicC topic-instance)) + (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (abstract-topictype-constraint + (get-item-by-psi *abstract-topictype-constraint-psi* :revision revision)) + (exclusive-instance-constraint + (get-item-by-psi *exclusive-instance-psi* :revision revision)) + (subjectidentifier-constraint + (get-item-by-psi *subjectidentifier-constraint-psi* :revision revision)) + (subjectlocator-constraint + (get-item-by-psi *subjectlocator-constraint-psi* :revision revision)) + (topicname-constraint + (get-item-by-psi *topicname-constraint-psi* :revision revision)) + (topicoccurrence-constraint + (get-item-by-psi *topicoccurrence-constraint-psi* :revision revision)) + (uniqueoccurrence-constraint + (get-item-by-psi *uniqueoccurrence-constraint-psi* :revision revision)) + (roleplayer-constraint + (get-item-by-psi *roleplayer-constraint-psi* :revision revision)) + (otherrole-constraint + (get-item-by-psi *otherrole-constraint-psi* :revision revision)) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (get-item-by-psi *topictype-constraint-psi* + :revision revision)) (abstract-topictype-constraints nil) (exclusive-instance-constraints nil) (subjectidentifier-constraints nil) @@ -1241,35 +1393,51 @@ (topicname-constraints nil) (topicoccurrence-constraints nil) (uniqueoccurrence-constraints nil)) - - (loop for role in (player-in-roles topic-instance) - when (and (eq topictype-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - do (loop for other-role in (roles (parent role)) - when (eq constraint-role (instance-of other-role)) - do (let ((constraint-topic (player other-role))) + (loop for role in (player-in-roles topic-instance :revision revision) + when (and (eq topictype-role (instance-of role :revision revision)) + (eq applies-to (instance-of (parent role :revision revision) + :revision revision))) + do (loop for other-role in (roles (parent role :revision revision) + :revision revision) + when (eq constraint-role (instance-of other-role :revision revision)) + do (let ((constraint-topic (player other-role :revision revision))) (cond - ((topictype-of-p constraint-topic abstract-topictype-constraint) + ((topictype-of-p constraint-topic abstract-topictype-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic abstract-topictype-constraints)) - ((topictype-of-p constraint-topic exclusive-instance-constraint) + ((topictype-of-p constraint-topic exclusive-instance-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic exclusive-instance-constraints)) - ((topictype-of-p constraint-topic subjectidentifier-constraint) + ((topictype-of-p constraint-topic subjectidentifier-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic subjectidentifier-constraints)) - ((topictype-of-p constraint-topic subjectlocator-constraint) + ((topictype-of-p constraint-topic subjectlocator-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic subjectlocator-constraints)) - ((topictype-of-p constraint-topic topicname-constraint) + ((topictype-of-p constraint-topic topicname-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic topicname-constraints)) - ((topictype-of-p constraint-topic topicoccurrence-constraint) + ((topictype-of-p constraint-topic topicoccurrence-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic topicoccurrence-constraints)) - ((topictype-of-p constraint-topic uniqueoccurrence-constraint) + ((topictype-of-p constraint-topic uniqueoccurrence-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic uniqueoccurrence-constraints)) (t - (unless (or (topictype-of-p constraint-topic roleplayer-constraint) - (topictype-of-p constraint-topic otherrole-constraint)) - (error "Constraint-Topic \"~a\" could not be handled" (uri (first (psis constraint-topic)))))))))) + (unless (or + (topictype-of-p constraint-topic roleplayer-constraint + topictype topictype-constraint + nil revision) + (topictype-of-p constraint-topic otherrole-constraint + topictype topictype-constraint + nil revision)) + (error "Constraint-Topic \"~a\" could not be handled" + (uri (first (psis constraint-topic + :revision revision)))))))))) (list :abstract-topictype-constraints abstract-topictype-constraints - :exclusive-instance-constraints (list :exclusive-constraints exclusive-instance-constraints - :owner topic-instance) + :exclusive-instance-constraints + (list :exclusive-constraints exclusive-instance-constraints + :owner topic-instance) :subjectidentifier-constraints subjectidentifier-constraints :subjectlocator-constraints subjectlocator-constraints :topicname-constraints topicname-constraints @@ -1277,7 +1445,8 @@ :uniqueoccurrence-constraints uniqueoccurrence-constraints))) -(defun get-all-constraint-topics-of-topic (topic-instance &key (treat-as 'type)) +(defun get-all-constraint-topics-of-topic (topic-instance &key (treat-as 'type) + (revision *TM-REVISION*)) "Returns a list of constraint-topics of the topics-instance's base type(s). If topic c is instanceOf a and b, there will be returned all constraint-topics of the topic types a and b. @@ -1285,112 +1454,157 @@ defined for the supertypes or the types of the passed topic - all constraints defined directly for the passed topic are ignored, unless the passed topic is an instance of itself." - (let ((akos-and-isas-of-this - (remove-duplicates - (if (eql treat-as 'type) - (progn - (topictype-p topic-instance) - (get-all-upper-constrainted-topics topic-instance)) - (progn - (valid-instance-p topic-instance) - (let ((topictypes - (get-direct-types-of-topic topic-instance)) - (all-constraints nil)) - (dolist (tt topictypes) - (let ((upts - (get-all-upper-constrainted-topics tt))) - (dolist (upt upts) - (pushnew upt all-constraints)))) - (remove-if #'(lambda(x) - (when (eql x topic-instance) - t)) - all-constraints))))))) - - (let ((all-abstract-topictype-constraints nil) - (all-exclusive-instance-constraints nil) - (all-subjectidentifier-constraints nil) - (all-subjectlocator-constraints nil) - (all-topicname-constraints nil) - (all-topicoccurrence-constraints nil) - (all-uniqueoccurrence-constraints nil)) - (loop for topic in akos-and-isas-of-this - do (let ((constraint-topics-of-topic (get-direct-constraint-topics-of-topic topic))) - (when (eq topic topic-instance) - (dolist (item (getf constraint-topics-of-topic :abstract-topictype-constraints)) - (pushnew item all-abstract-topictype-constraints))) - (let ((exclusive-instance-constraints - (getf constraint-topics-of-topic :exclusive-instance-constraints))) - (when (getf exclusive-instance-constraints :exclusive-constraints) - (push exclusive-instance-constraints all-exclusive-instance-constraints))) - (dolist (item (getf constraint-topics-of-topic :subjectidentifier-constraints)) - (pushnew item all-subjectidentifier-constraints)) - (dolist (item (getf constraint-topics-of-topic :subjectlocator-constraints)) - (pushnew item all-subjectlocator-constraints)) - (dolist (item (getf constraint-topics-of-topic :topicname-constraints)) - (pushnew item all-topicname-constraints)) - (dolist (item (getf constraint-topics-of-topic :topicoccurrence-constraints)) - (pushnew item all-topicoccurrence-constraints)) - (dolist (item (getf constraint-topics-of-topic :uniqueoccurrence-constraints)) - (pushnew item all-uniqueoccurrence-constraints)))) - (list :abstract-topictype-constraints all-abstract-topictype-constraints - :exclusive-instance-constraints all-exclusive-instance-constraints - :subjectidentifier-constraints all-subjectidentifier-constraints - :subjectlocator-constraints all-subjectlocator-constraints - :topicname-constraints all-topicname-constraints - :topicoccurrence-constraints all-topicoccurrence-constraints - :uniqueoccurrence-constraints all-uniqueoccurrence-constraints)))) + (declare (type (or integer null) revision) + (TopicC topic-instance) + (symbol treat-as)) + (let ((topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (get-item-by-psi *topictype-constraint-psi* + :revision revision))) + (let ((akos-and-isas-of-this + (remove-duplicates + (if (eql treat-as 'type) + (progn + (topictype-p topic-instance topictype topictype-constraint + nil revision) + (get-all-upper-constrainted-topics topic-instance + :revision revision)) + (progn + (valid-instance-p topic-instance nil nil revision) + (let ((topictypes + (get-direct-types-of-topic topic-instance + :revision revision)) + (all-constraints nil)) + (dolist (tt topictypes) + (let ((upts + (get-all-upper-constrainted-topics tt + :revision revision))) + (dolist (upt upts) + (pushnew upt all-constraints)))) + (remove-if #'(lambda(x) + (when (eql x topic-instance) + t)) + all-constraints))))))) + (let ((all-abstract-topictype-constraints nil) + (all-exclusive-instance-constraints nil) + (all-subjectidentifier-constraints nil) + (all-subjectlocator-constraints nil) + (all-topicname-constraints nil) + (all-topicoccurrence-constraints nil) + (all-uniqueoccurrence-constraints nil)) + (loop for topic in akos-and-isas-of-this + do (let ((constraint-topics-of-topic + (get-direct-constraint-topics-of-topic topic + :revision revision))) + (when (eq topic topic-instance) + (dolist (item (getf constraint-topics-of-topic + :abstract-topictype-constraints)) + (pushnew item all-abstract-topictype-constraints))) + (let ((exclusive-instance-constraints + (getf constraint-topics-of-topic + :exclusive-instance-constraints))) + (when (getf exclusive-instance-constraints :exclusive-constraints) + (push exclusive-instance-constraints + all-exclusive-instance-constraints))) + (dolist (item (getf constraint-topics-of-topic + :subjectidentifier-constraints)) + (pushnew item all-subjectidentifier-constraints)) + (dolist (item (getf constraint-topics-of-topic + :subjectlocator-constraints)) + (pushnew item all-subjectlocator-constraints)) + (dolist (item (getf constraint-topics-of-topic + :topicname-constraints)) + (pushnew item all-topicname-constraints)) + (dolist (item (getf constraint-topics-of-topic + :topicoccurrence-constraints)) + (pushnew item all-topicoccurrence-constraints)) + (dolist (item (getf constraint-topics-of-topic + :uniqueoccurrence-constraints)) + (pushnew item all-uniqueoccurrence-constraints)))) + (list :abstract-topictype-constraints all-abstract-topictype-constraints + :exclusive-instance-constraints all-exclusive-instance-constraints + :subjectidentifier-constraints all-subjectidentifier-constraints + :subjectlocator-constraints all-subjectlocator-constraints + :topicname-constraints all-topicname-constraints + :topicoccurrence-constraints all-topicoccurrence-constraints + :uniqueoccurrence-constraints all-uniqueoccurrence-constraints))))) -(defun get-direct-constraint-topics-of-association(associationtype-topic) +(defun get-direct-constraint-topics-of-association(associationtype-topic + &key (revision *TM-REVISION*)) "Returns all direct constraint topics defined for associations if the passed associationtype-topic" - (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) - (associationtype-role (get-item-by-psi *associationtype-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (associationtypescope-constraint (get-item-by-psi *associationtypescope-constraint-psi*)) - (associationrole-constraint (get-item-by-psi *associationrole-constraint-psi*)) - (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*)) - (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*)) + (declare (type (or integer null) revision) + (TopicC associationtype-topic)) + (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (associationtype-role (get-item-by-psi *associationtype-role-psi* + :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (associationtypescope-constraint + (get-item-by-psi *associationtypescope-constraint-psi* :revision revision)) + (associationrole-constraint (get-item-by-psi *associationrole-constraint-psi* + :revision revision)) + (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi* + :revision revision)) + (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi* + :revision revision)) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (get-item-by-psi *topictype-constraint-psi* + :revision revision)) (associationrole-constraints nil) (roleplayer-constraints nil) (otherrole-constraints nil)) - - (loop for role in (player-in-roles associationtype-topic) - when (and (eq associationtype-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - do (loop for other-role in (roles (parent role)) - when (eq constraint-role (instance-of other-role)) - do (let ((constraint-topic (player other-role))) + (loop for role in (player-in-roles associationtype-topic :revision revision) + when (and (eq associationtype-role (instance-of role :revision revision)) + (eq applies-to (instance-of (parent role :revision revision) + :revision revision))) + do (loop for other-role in (roles (parent role :revision revision) + :revision revision) + when (eq constraint-role (instance-of other-role :revision revision)) + do (let ((constraint-topic (player other-role :revision revision))) (cond - ((topictype-of-p constraint-topic associationtypescope-constraint) + ((topictype-of-p constraint-topic associationtypescope-constraint + topictype topictype-constraint nil revision) t) ;do nothing - ((topictype-of-p constraint-topic associationrole-constraint) + ((topictype-of-p constraint-topic associationrole-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic associationrole-constraints)) - ((topictype-of-p constraint-topic roleplayer-constraint) + ((topictype-of-p constraint-topic roleplayer-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic roleplayer-constraints)) - ((topictype-of-p constraint-topic otherrole-constraint) + ((topictype-of-p constraint-topic otherrole-constraint + topictype topictype-constraint nil revision) (pushnew constraint-topic otherrole-constraints)) (t - (error "Constraint-Topic \"~a\" could not be handled" (uri (first (psis constraint-topic))))))))) - + (error "Constraint-Topic \"~a\" could not be handled" + (uri (first (psis constraint-topic + :revision revision))))))))) (list :associationrole-constraints associationrole-constraints :roleplayer-constraints roleplayer-constraints :otherrole-constraints otherrole-constraints))) -(defun get-all-constraint-topics-of-association(associationtype-topic) +(defun get-all-constraint-topics-of-association(associationtype-topic &key + (revision *TM-REVISION*)) "Returns all constraint topics defined for associations if the passed associationtype-topic." - (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (is-type-constrained :what *associationtype-constraint-psi*)) + (declare (type (or integer null) revision) + (TopicC associationtype-topic)) + (topictype-p associationtype-topic + (get-item-by-psi *associationtype-psi* :revision revision) + (is-type-constrained :what *associationtype-constraint-psi* + :revision revision) nil revision) (let ((akos-and-isas-of-this - (get-all-upper-constrainted-topics associationtype-topic))) + (get-all-upper-constrainted-topics associationtype-topic + :revision revision))) (let ((all-associationrole-constraints nil) (all-roleplayer-constraints nil) (all-otherrole-constraints nil)) (loop for topic in akos-and-isas-of-this do (let ((constraint-topics-of-topic - (get-direct-constraint-topics-of-association topic))) - (dolist (item (getf constraint-topics-of-topic :associationrole-constraints)) + (get-direct-constraint-topics-of-association topic + :revision revision))) + (dolist (item (getf constraint-topics-of-topic + :associationrole-constraints)) (pushnew item all-associationrole-constraints)) (dolist (item (getf constraint-topics-of-topic :roleplayer-constraints)) (pushnew item all-roleplayer-constraints)) @@ -1401,105 +1615,173 @@ :otherrole-constraints all-otherrole-constraints)))) -(defun get-available-associations-of-topic(topic-instance &key (treat-as 'type)) +(defun get-available-associations-of-topic(topic-instance &key (treat-as 'type) + (revision *TM-REVISION*)) "Returns a list of topics decribing the available associationtype for the passed topic." - (let ((applies-to (get-item-by-psi *applies-to-psi*)) - (topictype-role (get-item-by-psi *topictype-role-psi*)) - (constraint-role (get-item-by-psi *constraint-role-psi*)) - (othertopictype-role (get-item-by-psi *othertopictype-role-psi*)) - (associationtype-role (get-item-by-psi *associationtype-role-psi*)) - (associationtype (get-item-by-psi *associationtype-psi*)) - (associationtype-constraint (get-item-by-psi *associationtype-constraint-psi*)) - (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi*)) - (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi*)) - (all-possible-player-topics - (remove-duplicates - (if (eql treat-as 'type) - (topictype-p topic-instance) - (valid-instance-p topic-instance))))) - (let ((all-available-associationtypes + (declare (type (or integer null) revision) + (TopicC topic-instance) + (symbol treat-as)) + (let ((topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (get-item-by-psi *topictype-constraint-psi* + :revision revision))) + (let ((applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) + (constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (othertopictype-role (get-item-by-psi *othertopictype-role-psi* + :revision revision)) + (associationtype-role (get-item-by-psi *associationtype-role-psi* + :revision revision)) + (associationtype (get-item-by-psi *associationtype-psi* :revision revision)) + (associationtype-constraint + (get-item-by-psi *associationtype-constraint-psi* :revision revision)) + (roleplayer-constraint (get-item-by-psi *roleplayer-constraint-psi* + :revision revision)) + (otherrole-constraint (get-item-by-psi *otherrole-constraint-psi* + :revision revision)) + (all-possible-player-topics (remove-duplicates - (loop for possible-player-topic in all-possible-player-topics - append (loop for role in (player-in-roles possible-player-topic) - when (and (or (eq topictype-role (instance-of role)) - (eq othertopictype-role (instance-of role))) - (eq applies-to (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (and (eq constraint-role (instance-of other-role)) - (or (topictype-of-p (player other-role) roleplayer-constraint) - (topictype-of-p (player other-role) otherrole-constraint))) - append (loop for c-role in (player-in-roles (player other-role)) - when (and (eq constraint-role (instance-of c-role)) - (eq applies-to (instance-of (parent c-role)))) - append (loop for type-role in (roles (parent c-role)) - when (eq associationtype-role (instance-of type-role)) - append (map 'list #'(lambda(x) - (topictype-p x associationtype associationtype-constraint) - x) - (getf (list-subtypes (player type-role) associationtype associationtype-constraint) :subtypes)))))))))) - all-available-associationtypes))) + (if (eql treat-as 'type) + (topictype-p topic-instance topictype topictype-constraint nil + revision) + (valid-instance-p topic-instance nil nil revision))))) + (let ((all-available-associationtypes + (remove-duplicates + (loop for possible-player-topic in all-possible-player-topics + append + (loop for role in (player-in-roles possible-player-topic + :revision revision) + when (and (or (eq topictype-role + (instance-of role :revision revision)) + (eq othertopictype-role + (instance-of role :revision revision))) + (eq applies-to + (instance-of (parent role :revision revision) + :revision revision))) + append + (loop for other-role in + (roles (parent role :revision revision) + :revision revision) + when (and (eq constraint-role + (instance-of other-role :revision revision)) + (or (topictype-of-p + (player other-role :revision revision) + roleplayer-constraint topictype + topictype-constraint nil revision) + (topictype-of-p + (player other-role :revision revision) + otherrole-constraint topictype + topictype-constraint nil revision))) + append + (loop for c-role in + (player-in-roles + (player other-role :revision revision) + :revision revision) + when (and (eq constraint-role + (instance-of c-role :revision revision)) + (eq applies-to + (instance-of (parent c-role + :revision revision) + :revision revision))) + append + (loop for type-role in + (roles (parent c-role :revision revision) + :revision revision) + when (eq associationtype-role + (instance-of type-role + :revision revision)) + append + (map + 'list + #'(lambda(x) + (topictype-p x associationtype + associationtype-constraint + nil revision) + x) + (getf (list-subtypes + (player type-role :revision revision) + associationtype + associationtype-constraint nil + nil revision) :subtypes)))))))))) + all-available-associationtypes)))) -(defun topics-to-json-list (topics) +(defun topics-to-json-list (topics &key (revision *TM-REVISION*)) "Returns a json list of psi-lists." + (declare (list topics) + (type (or integer null) revision)) (json:encode-json-to-string (map 'list #'(lambda(topic) - (map 'list #'uri (psis topic))) + (map 'list #'uri (psis topic :revision revision))) topics))) (defun tree-view-to-json-string (tree-views) "Returns a full tree-view as json-string." (let ((json-string - (concatenate 'string "[" - (if tree-views - (let ((inner-string "")) - (loop for tree-view in tree-views - do (setf inner-string (concatenate 'string inner-string (node-to-json-string tree-view) ","))) - (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]")) - "null")))) + (concatenate + 'string "[" + (if tree-views + (let ((inner-string "")) + (loop for tree-view in tree-views + do (setf inner-string + (concatenate 'string inner-string + (node-to-json-string tree-view) ","))) + (concatenate 'string (subseq inner-string 0 + (- (length inner-string) 1)) "]")) + "null")))) json-string)) -(defun make-tree-view () + +(defun make-tree-view (&key (revision *TM-REVISION*)) "Returns a list of the form: ((<topictype> (direct-instances) (direc-subtypes)) (<...>)); -> direct-instances: (<any-topic> (direct-instances) (direct-subtypes)) -> direct-subtypes: (<any-topic> (direct-instances) (direct-subtypes))" - (let ((topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*)) - (topictype-constraint (is-type-constrained))) + (declare (type (or integer null) revision)) + (let ((topictype + (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (is-type-constrained :revision revision))) (if topictype-constraint (progn (unless topictype (error "From make-tree-view(): The topictype-constraint \"~a\" exists but the topictype \"~a\" is missing!" - json-tmcl-constants::*topictype-constraint-psi* - json-tmcl-constants::*topictype-psi*)) - (list (make-nodes topictype t t))) + *topictype-constraint-psi* + *topictype-psi*)) + (list (make-nodes topictype t t :revision revision))) (let ((tree-roots - (get-all-tree-roots))) + (get-all-tree-roots :revision revision))) (let ((tree-list (loop for root in tree-roots - collect (let ((l-is-type - (handler-case (progn - (topictype-p root topictype topictype-constraint) - t) - (Condition () nil))) - (l-is-instance - (handler-case (progn - (valid-instance-p root) - t) - (Condition () nil)))) - (make-nodes root l-is-type l-is-instance))))) + collect + (let ((l-is-type + (handler-case + (progn + (topictype-p root topictype topictype-constraint + nil revision) + t) + (Condition () nil))) + (l-is-instance + (handler-case (progn + (valid-instance-p root nil nil revision) + t) + (Condition () nil)))) + (make-nodes root l-is-type l-is-instance + :revision revision))))) tree-list))))) -(defun node-to-json-string(node) +(defun node-to-json-string(node &key (revision *TM-REVISION*)) "Returns a json-object of the form {topic: [<psis>], isType: <bool>, isInstance: <bool>, instances: [<nodes>], subtypes: [<nodes>]}." + (declare (type (or integer null) revision) + (list node)) (let ((topic-psis - (concatenate 'string "\"topic\":" - (json:encode-json-to-string (map 'list #'d:uri (d:psis (getf node :topic)))))) + (concatenate + 'string "\"topic\":" + (json:encode-json-to-string + (map 'list #'d:uri (d:psis (getf node :topic) :revision revision))))) (is-type (concatenate 'string "\"isType\":" (if (getf node :is-type) @@ -1511,82 +1793,116 @@ "true" "false"))) (instances - (concatenate 'string "\"instances\":" - (if (getf node :instances) - (let ((inner-string "[")) - (loop for instance-node in (getf node :instances) - do (setf inner-string (concatenate 'string inner-string (node-to-json-string instance-node) ","))) - (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]")) - "null"))) + (concatenate + 'string "\"instances\":" + (if (getf node :instances) + (let ((inner-string "[")) + (loop for instance-node in (getf node :instances) + do (setf inner-string + (concatenate + 'string inner-string + (node-to-json-string instance-node :revision revision) + ","))) + (concatenate 'string (subseq inner-string 0 + (- (length inner-string) 1)) "]")) + "null"))) (subtypes - (concatenate 'string "\"subtypes\":" - (if (getf node :subtypes) - (let ((inner-string "[")) - (loop for instance-node in (getf node :subtypes) - do (setf inner-string (concatenate 'string inner-string (node-to-json-string instance-node) ","))) - (concatenate 'string (subseq inner-string 0 (- (length inner-string) 1)) "]")) - "null")))) - (concatenate 'string "{" topic-psis "," is-type "," is-instance "," instances "," subtypes"}"))) + (concatenate + 'string "\"subtypes\":" + (if (getf node :subtypes) + (let ((inner-string "[")) + (loop for instance-node in (getf node :subtypes) + do (setf inner-string + (concatenate 'string inner-string + (node-to-json-string instance-node + :revision revision) + ","))) + (concatenate 'string (subseq inner-string 0 + (- (length inner-string) 1)) "]")) + "null")))) + (concatenate 'string "{" topic-psis "," is-type "," is-instance "," instances + "," subtypes"}"))) -(defun make-nodes (topic-instance is-type is-instance) +(defun make-nodes (topic-instance is-type is-instance &key (revision *TM-REVISION*)) "Creates a li of nodes. A node looks like - (:topic <topic> :is-type <bool> :is-instance <bool> :instances <node> :subtypes <nodes>)." - (declare (d:TopicC topic-instance)) - (let ((topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*)) - (topictype-constraint (is-type-constrained))) + (:topic <topic> :is-type <bool> :is-instance <bool> :instances <node> + :subtypes <nodes>)." + (declare (TopicC topic-instance) + (type (or integer null) revision)) + (let ((topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (is-type-constrained :revision revision))) (let ((isas-of-this - (map 'list #'(lambda(z) - (let ((l-is-type - (handler-case (progn - (topictype-p z topictype topictype-constraint) - t) - (Condition () nil))) - (l-is-instance - (handler-case (progn - (valid-instance-p z) - t) - (Condition () nil)))) - (list :topic z :is-type l-is-type :is-instance l-is-instance))) + (map + 'list + #'(lambda(z) + (let ((l-is-type + (handler-case + (progn + (topictype-p z topictype topictype-constraint + nil revision) + t) + (Condition () nil))) + (l-is-instance + (handler-case (progn + (valid-instance-p z nil nil revision) + t) + (Condition () nil)))) + (list :topic z :is-type l-is-type :is-instance l-is-instance))) (remove-duplicates (remove-if #'null - (remove-if #'(lambda(x) (when (eql topic-instance x) - t)) - (get-direct-instances-of-topic topic-instance)))))) + (remove-if + #'(lambda(x) (when (eql topic-instance x) + t)) + (get-direct-instances-of-topic topic-instance + :revision revision)))))) (akos-of-this - (map 'list #'(lambda(z) - (let ((l-is-type - (handler-case (progn - (topictype-p z topictype topictype-constraint) - t) - (Condition () nil))) - (l-is-instance - (handler-case (progn - (valid-instance-p z) - t) - (Condition () nil)))) - (list :topic z :is-type l-is-type :is-instance l-is-instance))) + (map 'list + #'(lambda(z) + (let ((l-is-type + (handler-case + (progn + (topictype-p z topictype topictype-constraint + nil revision) + t) + (Condition () nil))) + (l-is-instance + (handler-case (progn + (valid-instance-p z nil nil revision) + t) + (Condition () nil)))) + (list :topic z :is-type l-is-type :is-instance l-is-instance))) (remove-duplicates - (remove-if #'null - (remove-if #'(lambda(x) (when (eql topic-instance x) - t)) - (get-direct-subtypes-of-topic topic-instance))))))) + (remove-if + #'null + (remove-if #'(lambda(x) (when (eql topic-instance x) + t)) + (get-direct-subtypes-of-topic topic-instance + :revision revision))))))) (let ((cleaned-isas ;;all constraint topics are removed - (clean-topic-entries isas-of-this)) + (clean-topic-entries isas-of-this :revision revision)) (cleaned-akos ;;all constraint topics are removed - (clean-topic-entries akos-of-this))) + (clean-topic-entries akos-of-this :revision revision))) (list :topic topic-instance :is-type is-type :is-instance is-instance :instances (map 'list #'(lambda(x) - (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) + (make-nodes (getf x :topic) + (getf x :is-type) + (getf x :is-instance) + :revision revision)) cleaned-isas) :subtypes (map 'list #'(lambda(x) - (make-nodes (getf x :topic) (getf x :is-type) (getf x :is-instance))) + (make-nodes (getf x :topic) + (getf x :is-type) + (getf x :is-instance) + :revision revision)) cleaned-akos)))))) -(defun clean-topic-entries(isas-or-akos) + +(defun clean-topic-entries(isas-or-akos &key (revision *TM-REVISION*)) + "Removes all TMCL-topics from the passed topic-list." (remove-if #'null (map 'list @@ -1602,33 +1918,31 @@ (string= (uri psi) *scopetype-psi*) (string= (uri psi) *schema-psi*)) top-entry)) - (psis (getf top-entry :topic)))) + (psis (getf top-entry :topic) :revision revision))) top-entry)) isas-or-akos))) -(defun get-all-tree-roots () +(defun get-all-tree-roots (&key (revision *TM-REVISION*)) "Returns all topics that are no instanceOf and no subtype of any other topic." - (let ((all-topics - (remove-if #'null - (map 'list - #'(lambda(top) - (when (d:find-item-by-revision top 0) - top)) - (elephant:get-instances-by-class 'd:TopicC))))) - (remove-if #'null - (map 'list #'(lambda(x) - (let ((isas-of-x - (remove-if #'(lambda(y) - (when (eql y x) - t)) - (get-direct-types-of-topic x))) - (akos-of-x - (remove-if #'(lambda(y) - (when (eql y x) - t)) - (get-direct-supertypes-of-topic x)))) - (unless (or isas-of-x akos-of-x) - x))) - all-topics)))) \ No newline at end of file + (declare (type (or integer null) revision)) + (let ((all-topics (get-all-topics revision))) + (remove-if + #'null + (map 'list + #'(lambda(x) + (let ((isas-of-x + (remove-if #'(lambda(y) + (when (eql y x) + t)) + (get-direct-types-of-topic x :revision revision))) + (akos-of-x + (remove-if + #'(lambda(y) + (when (eql y x) + t)) + (get-direct-supertypes-of-topic x :revision revision)))) + (unless (or isas-of-x akos-of-x) + x))) + all-topics)))) \ No newline at end of file Modified: trunk/src/json/json_tmcl_constants.lisp ============================================================================== --- trunk/src/json/json_tmcl_constants.lisp (original) +++ trunk/src/json/json_tmcl_constants.lisp Sun Oct 10 05:41:19 2010 @@ -53,9 +53,6 @@ (in-package :json-tmcl-constants) - -(defparameter *schema-psi* "http://psi.topicmaps.org/tmcl/schema") -(defparameter *constraint-psi* "http://psi.topicmaps.org/tmcl/constraint") (defparameter *topictype-psi* "http://psi.topicmaps.org/tmcl/topic-type") (defparameter *topictype-constraint-psi* "http://psi.topicmaps.org/tmcl/topic-type-constraint") (defparameter *associationtype-psi* "http://psi.topicmaps.org/tmcl/association-type") @@ -94,4 +91,6 @@ (defparameter *otherroletype-role-psi* "http://psi.topicmaps.org/tmcl/other-role-type-role") (defparameter *associationtype-role-psi* "http://psi.topicmaps.org/tmcl/association-type-role") (defparameter *associationrole-constraint-psi* "http://psi.topicmaps.org/tmcl/association-role-constraint") -(defparameter *roletype-role-psi* "http://psi.topicmaps.org/tmcl/role-type-role") \ No newline at end of file +(defparameter *roletype-role-psi* "http://psi.topicmaps.org/tmcl/role-type-role") +(defparameter *schema-psi* "http://psi.topicmaps.org/tmcl/schema") +(defparameter *constraint-psi* "http://psi.topicmaps.org/tmcl/constraint") \ No newline at end of file Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Sun Oct 10 05:41:19 2010 @@ -19,261 +19,319 @@ (in-package :json-tmcl) -(defun abstract-p (topic-instance) +(defun abstract-p (topic-instance &key (revision *TM-REVISION*)) "Returns t if this topic type is an abstract topic type." - (let ((constraint-role (get-item-by-psi *constraint-role-psi*)) - (topictype-role (get-item-by-psi *topictype-role-psi*)) - (applies-to (get-item-by-psi *applies-to-psi*)) - (abstract-topictype-constraint (get-item-by-psi *abstract-topictype-constraint-psi*))) - - (loop for role in (player-in-roles topic-instance) - when (and (eq topictype-role (instance-of role)) - (eq applies-to (instance-of (parent role)))) - return (loop for other-role in (roles (parent role)) - when (and (eq constraint-role (instance-of other-role)) - (topictype-of-p (player other-role) abstract-topictype-constraint)) + (declare (type (or integer null) revision) + (TopicC topic-instance)) + (let ((constraint-role (get-item-by-psi *constraint-role-psi* :revision revision)) + (topictype-role (get-item-by-psi *topictype-role-psi* :revision revision)) + (applies-to (get-item-by-psi *applies-to-psi* :revision revision)) + (abstract-topictype-constraint + (get-item-by-psi *abstract-topictype-constraint-psi* :revision revision))) + (loop for role in (player-in-roles topic-instance :revision revision) + when (and (eq topictype-role (instance-of role :revision revision)) + (eq applies-to (instance-of (parent role :revision revision) + :revision revision))) + return (loop for other-role in (roles (parent role :revision revision) + :revision revision) + when (and (eq constraint-role (instance-of other-role + :revision revision)) + (topictype-of-p (player other-role :revision revision) + abstract-topictype-constraint nil nil + nil revision)) return t)))) -(defun topictype-of-p (topic-instance type-instance &optional (topictype (get-item-by-psi *topictype-psi*)) - (topictype-constraint (is-type-constrained)) - checked-topics) +(defun topictype-of-p (topic-instance type-instance &optional + (topictype (get-item-by-psi *topictype-psi* :revision 0)) + (topictype-constraint (is-type-constrained :revision 0)) + checked-topics (revision *TM-REVISION*)) "Returns a list of all types and supertypes of this topic if this topic is a valid instance-topic of the type-topic called type-instance. TMCL 4.4.2. When the type-instance is set to nil there will be checked only if the topic-instance is a valid instance." + (declare (type (or integer null) revision) + (TopicC topic-instance) + (type (or TopicC null) topictype-constraint) + (list checked-topics)) (let ((current-checked-topics (append checked-topics (list topic-instance))) - (isas-of-this (get-direct-types-of-topic topic-instance)) - (akos-of-this (get-direct-supertypes-of-topic topic-instance))) - + (isas-of-this (get-direct-types-of-topic topic-instance :revision revision)) + (akos-of-this (get-direct-supertypes-of-topic topic-instance + :revision revision))) (when (eq topic-instance topictype) t) - (when (and (not isas-of-this) (not akos-of-this)) (return-from topictype-of-p nil)) - (loop for isa-of-this in isas-of-this - do (let ((found-topics (topictype-p isa-of-this topictype topictype-constraint))) + do (let ((found-topics + (topictype-p isa-of-this topictype topictype-constraint nil revision))) (when (not found-topics) (return-from topictype-of-p nil)) (dolist (item found-topics) (pushnew item current-checked-topics)))) - (loop for ako-of-this in akos-of-this when (not (find ako-of-this current-checked-topics :test #'eq)) - do (let ((found-topics (topictype-of-p ako-of-this type-instance topictype topictype-constraint current-checked-topics))) + do (let ((found-topics + (topictype-of-p ako-of-this type-instance topictype + topictype-constraint current-checked-topics + revision))) (when (not found-topics) (return-from topictype-of-p nil)) (dolist (item found-topics) (pushnew item current-checked-topics)))) - (if type-instance (when (find type-instance current-checked-topics) current-checked-topics) current-checked-topics))) -(defun topictype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) - (topictype-constraint (is-type-constrained)) - (checked-topics nil)) +(defun topictype-p (topic-instance &optional + (topictype (get-item-by-psi *topictype-psi* :revision 0)) + (topictype-constraint (is-type-constrained :revision 0)) + (checked-topics nil) (revision *TM-REVISION*)) "Returns a list of all instanceOf-topics and all Supertypes of this topic if this topic is a valid topic (-type). I.e. the passed topic is the topictype or it is an instanceOf of the topictype or it is a subtype of the topictype. TMDM 7.2 + TMDM 7.3" - ;(format t "~%~%topictype-p ~a~%" (uri (first (psis topic-instance)))) + (declare (type (or integer null) revision) + (type (or TopicC null) topictype topic-instance) + (list checked-topics)) (let ((current-checked-topics (append checked-topics (list topic-instance))) - (akos-of-this (get-direct-supertypes-of-topic topic-instance)) - (isas-of-this (get-direct-types-of-topic topic-instance))) - + (akos-of-this (get-direct-supertypes-of-topic topic-instance + :revision revision)) + (isas-of-this (get-direct-types-of-topic topic-instance :revision revision))) (when (eq topictype topic-instance) (return-from topictype-p current-checked-topics)) - (when (not (union akos-of-this isas-of-this :test #'eq)) (when topictype-constraint - ;(return-from topictype-p nil)) - (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype))))) + (error "~a is not a valid type for ~a" + (uri (first (psis topic-instance :revision revision))) + (uri (first (psis topictype :revision revision))))) (return-from topictype-p current-checked-topics)) - (let ((akos-are-topictype nil)) (loop for ako-of-this in akos-of-this when (not (find ako-of-this current-checked-topics)) - do (let ((further-topics (topictype-p ako-of-this topictype topictype-constraint))) + do (let ((further-topics + (topictype-p ako-of-this topictype topictype-constraint + nil revision))) (if further-topics (progn (dolist (item further-topics) (pushnew item current-checked-topics)) (pushnew ako-of-this akos-are-topictype)) (when topictype-constraint - ;(return-from topictype-p nil))))) - (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype)))))))) - + (error "~a is not a valid type for ~a" + (uri (first (psis topic-instance :revision revision))) + (uri (first (psis topictype :revision revision)))))))) (when isas-of-this (let ((topictype-topics-of-isas nil)) (loop for isa-of-this in isas-of-this - do (let ((topic-akos (subtype-p isa-of-this topictype))) + do (let ((topic-akos (subtype-p isa-of-this topictype nil revision))) (when topic-akos (pushnew isa-of-this topictype-topics-of-isas) (pushnew isa-of-this current-checked-topics) (dolist (item topic-akos) (pushnew item current-checked-topics))))) - (when (and (not topictype-topics-of-isas) (not akos-are-topictype) topictype-constraint) - ;(return-from topictype-p nil)) - (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype))))) - + (error "~a is not a valid type for ~a" + (uri (first (psis topic-instance :revision revision))) + (uri (first (psis topictype :revision revision))))) (loop for isa-of-this in isas-of-this when (and (not (find isa-of-this current-checked-topics :test #'eq)) (not (find isa-of-this topictype-topics-of-isas :test #'eq))) - do (let ((further-topic-types (topictype-p isa-of-this topictype topictype-constraint current-checked-topics))) + do (let ((further-topic-types + (topictype-p isa-of-this topictype topictype-constraint + current-checked-topics revision))) (if further-topic-types (dolist (item further-topic-types) (pushnew item current-checked-topics)) (when topictype-constraint - ;(return-from topictype-p nil)))))))) - (error "~a is not a valid type for ~a" (uri (first (psis topic-instance))) (uri (first (psis topictype))))))))))) + (error "~a is not a valid type for ~a" + (uri (first (psis topic-instance :revision revision))) + (uri (first (psis topictype :revision revision))))))))))) current-checked-topics)) -(defun subtype-p (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) (checked-topics nil)) +(defun subtype-p (topic-instance &optional + (topictype (get-item-by-psi *topictype-psi* :revision 0)) + (checked-topics nil) (revision *TM-REVISION*)) "Returns a list of all supertypes of the passed topic if the passed topic is not an instanceOf any other topic but a subtype of some supertypes of a topictype or it is the topictype-topic itself. This function isn't useable as a standalone function - it's only necessary for a special case in the function topictype-p." - ;(format t "~%~%subtype-p ~a~%" (uri (first (psis topic-instance)))) - (let ((current-checked-topics (remove-duplicates (append checked-topics (list topic-instance))))) - + (declare (type (or integer null) revision) + (TopicC topic-instance) + (type (or TopicC null) topictype) + (list checked-topics)) + (let ((current-checked-topics + (remove-duplicates (append checked-topics (list topic-instance))))) (when (eq topictype topic-instance) (return-from subtype-p current-checked-topics)) - - (when (get-direct-types-of-topic topic-instance) + (when (get-direct-types-of-topic topic-instance :revision revision) (return-from subtype-p nil)) - - (let ((supertypes-of-this (get-direct-supertypes-of-topic topic-instance))) + (let ((supertypes-of-this + (get-direct-supertypes-of-topic topic-instance :revision revision))) (when (not supertypes-of-this) (return-from subtype-p nil)) (when supertypes-of-this (loop for supertype-of-this in supertypes-of-this when (not (find supertype-of-this current-checked-topics :test #'eq)) - do (let ((further-supertypes (subtype-p topictype supertype-of-this current-checked-topics))) + do (let ((further-supertypes + (subtype-p topictype supertype-of-this current-checked-topics + revision))) (when (not further-supertypes) (return-from subtype-p nil)) - (dolist (item further-supertypes) (pushnew item current-checked-topics)))))) - current-checked-topics)) -(defun get-direct-types-of-topic(topic-instance) +(defun get-direct-types-of-topic(topic-instance &key (revision *TM-REVISION*)) "Returns the direct types of the topic as a list passed to this function. This function only returns the types of the type-instance-relationship -> TMDM 7.2 This function was defined for the use in topictype-p and not for a standalone usage." - (let ((type-instance (get-item-by-psi *type-instance-psi*)) - (instance (get-item-by-psi *instance-psi*)) - (type (get-item-by-psi *type-psi*))) + (declare (type (or integer null) revision) + (TopicC topic-instance)) + (let ((type-instance (get-item-by-psi *type-instance-psi* :revision revision)) + (instance (get-item-by-psi *instance-psi* :revision revision)) + (type (get-item-by-psi *type-psi* :revision revision))) (let ((topic-types - (loop for role in (player-in-roles topic-instance) - when (eq instance (instance-of role)) - collect (loop for other-role in (roles (parent role)) + (loop for role in (player-in-roles topic-instance :revision revision) + when (eq instance (instance-of role :revision revision)) + collect (loop for other-role in + (roles (parent role :revision revision) :revision revision) when (and (not (eq role other-role)) - (eq type-instance (instance-of (parent role))) - (eq type (instance-of other-role))) - return (player other-role))))) + (eq type-instance (instance-of + (parent role :revision revision) + :revision revision)) + (eq type (instance-of other-role + :revision revision))) + return (player other-role :revision revision))))) (when topic-types (remove-if #'null topic-types))))) -(defun get-direct-instances-of-topic(topic-instance) +(defun get-direct-instances-of-topic(topic-instance &key (revision *TM-REVISION*)) "Returns the direct instances of the topic as a list. This function only returns the types of the type-instance-relationship -> TMDM 7.2 This function was defined for the use in topictype-p and not for a standalone usage." - (let ((type-instance (get-item-by-psi *type-instance-psi*)) - (instance (get-item-by-psi *instance-psi*)) - (type (get-item-by-psi *type-psi*))) + (declare (type (or integer null) revision) + (TopicC topic-instance)) + (let ((type-instance (get-item-by-psi *type-instance-psi* :revision revision)) + (instance (get-item-by-psi *instance-psi* :revision revision)) + (type (get-item-by-psi *type-psi* :revision revision))) (let ((topic-instances - (loop for role in (player-in-roles topic-instance) - when (eq type (instance-of role)) - collect (loop for other-role in (roles (parent role)) + (loop for role in (player-in-roles topic-instance :revision revision) + when (eq type (instance-of role :revision revision)) + collect (loop for other-role in (roles (parent role :revision revision) + :revision revision) when (and (not (eq role other-role)) - (eq type-instance (instance-of (parent role))) - (eq instance (instance-of other-role))) - return (player other-role))))) + (eq type-instance + (instance-of (parent role :revision revision) + :revision revision)) + (eq instance (instance-of other-role + :revision revision))) + return (player other-role :revision revision))))) (when topic-instances (remove-if #'null topic-instances))))) -(defun get-direct-supertypes-of-topic(topic-instance) +(defun get-direct-supertypes-of-topic(topic-instance &key (revision *TM-REVISION*)) "Returns the direct supertypes of the topic as a list passed to this function. This function only returns the types of the supertype-subtype-relationship -> TMDM 7.3. This function was defined for the use in topictype-p and not for a standalone usage." - (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi*)) - (supertype (get-item-by-psi *supertype-psi*)) - (subtype (get-item-by-psi *subtype-psi*))) + (declare (type (or integer null) revision) + (TopicC topic-instance)) + (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi* :revision revision)) + (supertype (get-item-by-psi *supertype-psi* :revision revision)) + (subtype (get-item-by-psi *subtype-psi* :revision revision))) (let ((supertypes - (loop for role in (player-in-roles topic-instance) - when (eq subtype (instance-of role)) - append (loop for other-role in (roles (parent role)) + (loop for role in (player-in-roles topic-instance :revision revision) + when (eq subtype (instance-of role :revision revision)) + append (loop for other-role in (roles (parent role :revision revision) + :revision revision) when (and (not (eq role other-role)) - (eq supertype-subtype (instance-of (parent role))) - (eq supertype (instance-of other-role))) + (eq supertype-subtype + (instance-of (parent role :revision revision) + :revision revision)) + (eq supertype + (instance-of other-role :revision revision))) collect (player other-role))))) (when supertypes (remove-if #'null supertypes))))) -(defun get-direct-subtypes-of-topic(topic-instance) +(defun get-direct-subtypes-of-topic(topic-instance &key (revision *TM-REVISION*)) "Returns the direct subtypes of the topic as a list. - This function only returns the types of the supertype-subtype-relationship -> TMDM 7.3. + This function only returns the types of the supertype-subtype-relationship + -> TMDM 7.3. This function was defined for the use in topictype-p and not for a standalone usage." - (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi*)) - (supertype (get-item-by-psi *supertype-psi*)) - (subtype (get-item-by-psi *subtype-psi*))) + (declare (type (or integer null) revision) + (TopicC topic-instance)) + (let ((supertype-subtype (get-item-by-psi *supertype-subtype-psi* :revision revision)) + (supertype (get-item-by-psi *supertype-psi* :revision revision)) + (subtype (get-item-by-psi *subtype-psi* :revision revision))) (let ((subtypes - (loop for role in (player-in-roles topic-instance) - when (eq supertype (instance-of role)) - append (loop for other-role in (roles (parent role)) + (loop for role in (player-in-roles topic-instance :revision revision) + when (eq supertype (instance-of role :revision revision)) + append (loop for other-role in (roles (parent role :revision revision) + :revision revision) when (and (not (eq role other-role)) - (eq supertype-subtype (instance-of (parent role))) - (eq subtype (instance-of other-role))) - collect (player other-role))))) + (eq supertype-subtype + (instance-of (parent role :revision revision) + :revision revision)) + (eq subtype (instance-of other-role + :revision revision))) + collect (player other-role :revision revision))))) (when subtypes (remove-if #'null subtypes))))) -(defun list-subtypes (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) - (topictype-constraint (is-type-constrained)) - (checked-topics nil) (valid-subtypes nil)) +(defun list-subtypes (topic-instance &optional + (topictype (get-item-by-psi *topictype-psi* :revision 0)) + (topictype-constraint (is-type-constrained :revision 0)) + (checked-topics nil) (valid-subtypes nil) + (revision *TM-REVISION*)) "Returns all valid subtypes of a topic, e.g.: nametype-constraint ako constraint . first-name isa nametype . first-name-1 ako first-name . // ... - The return value is a named list of the form (:subtypes (<topic> <...>) :checked-topics (<topic> <...>)" + The return value is a named list of the form (:subtypes (<topic> <...>) + :checked-topics (<topic> <...>)" (let ((current-checked-topics (append checked-topics (list topic-instance)))) - - (handler-case (topictype-p topic-instance topictype topictype-constraint) - (condition () (return-from list-subtypes (list :subtypes nil :checked-topics current-checked-topics)))) - - (let ((subtype (get-item-by-psi *subtype-psi*)) - (supertype (get-item-by-psi *supertype-psi*)) - (supertype-subtype (get-item-by-psi *supertype-subtype-psi*)) + (handler-case (topictype-p topic-instance topictype topictype-constraint + nil revision) + (condition () (return-from list-subtypes + (list :subtypes nil :checked-topics current-checked-topics)))) + (let ((subtype (get-item-by-psi *subtype-psi* :revision revision)) + (supertype (get-item-by-psi *supertype-psi* :revision revision)) + (supertype-subtype (get-item-by-psi *supertype-subtype-psi* + :revision revision)) (current-valid-subtypes (append valid-subtypes (list topic-instance)))) - (loop for role in (player-in-roles topic-instance) - when (and (eq supertype (instance-of role)) - (eq supertype-subtype (instance-of (parent role)))) - do (loop for other-role in (roles (parent role)) - do (when (and (eq subtype (instance-of other-role)) - (not (find (player other-role) current-checked-topics))) + (loop for role in (player-in-roles topic-instance :revision revision) + when (and (eq supertype (instance-of role :revision revision)) + (eq supertype-subtype + (instance-of (parent role :revision revision) + :revision revision))) + do (loop for other-role in (roles (parent role :revision revision) + :revision revision) + do (when (and (eq subtype (instance-of other-role :revision revision)) + (not (find (player other-role :revision revision) + current-checked-topics))) (let ((new-values - (list-subtypes (player other-role) topictype topictype-constraint current-checked-topics current-valid-subtypes))) + (list-subtypes (player other-role :revision revision) + topictype topictype-constraint + current-checked-topics + current-valid-subtypes revision))) (dolist (item (getf new-values :subtypes)) (pushnew item current-valid-subtypes)) (dolist (item (getf new-values :checked-topics)) @@ -281,172 +339,209 @@ (list :subtypes current-valid-subtypes :checked-topics current-checked-topics)))) -(defun list-instances (topic-instance &optional (topictype (get-item-by-psi *topictype-psi*)) - (topictype-constraint (is-type-constrained))) - "Returns the topic-instance, all subtypes found by the function list-subtypes and all direct - instances for the found subtypes." +(defun list-instances (topic-instance &optional + (topictype (get-item-by-psi *topictype-psi* :revision 0)) + (topictype-constraint (is-type-constrained :revision 0)) + (revision *TM-REVISION*)) + "Returns the topic-instance, all subtypes found by the function list-subtypes + and all direct instances for the found subtypes." (let ((all-subtypes-of-this - (getf (list-subtypes topic-instance topictype topictype-constraint) :subtypes)) - (type (get-item-by-psi *type-psi*)) - (instance (get-item-by-psi *instance-psi*)) - (type-instance (get-item-by-psi *type-instance-psi*))) + (getf (list-subtypes topic-instance topictype topictype-constraint + nil nil revision) + :subtypes)) + (type (get-item-by-psi *type-psi* :revision revision)) + (instance (get-item-by-psi *instance-psi* :revision revision)) + (type-instance (get-item-by-psi *type-instance-psi* :revision revision))) (let ((all-instances-of-this (remove-duplicates (loop for subtype-of-this in all-subtypes-of-this - append (loop for role in (player-in-roles subtype-of-this) - when (and (eq type (instance-of role)) - (eq type-instance (instance-of (parent role)))) - append (loop for other-role in (roles (parent role)) - when (eq instance (instance-of other-role)) - collect (player other-role))))))) + append (loop for role in (player-in-roles subtype-of-this + :revision revision) + when (and (eq type (instance-of role :revision revision)) + (eq type-instance + (instance-of (parent role :revision revision) + :revision revision))) + append (loop for other-role in + (roles (parent role :revision revision) + :revision revision) + when (eq instance (instance-of other-role + :revision revision)) + collect (player other-role :revision revision))))))) (let ((all-subtypes-of-all-instances (remove-if #'null (remove-duplicates (loop for subtype in all-instances-of-this - append (getf (list-subtypes subtype nil nil) :subtypes)))))) + append (getf + (list-subtypes subtype topictype + nil nil nil revision) + :subtypes)))))) (union all-instances-of-this (remove-if #'null (map 'list #'(lambda(x) (handler-case (progn - (topictype-of-p x nil) + (topictype-of-p x nil nil nil + nil revision) x) (condition () nil))) all-subtypes-of-all-instances))))))) -(defun valid-instance-p (topic-instance &optional (akos-checked nil) (all-checked-topics nil)) +(defun valid-instance-p (topic-instance &optional + (akos-checked nil) (all-checked-topics nil) + (revision *TM-REVISION*)) "Returns a list of all checked topics or throws an exception if the given topic is not a valid instance of any topictype in elephant." + (declare (type (or integer null) revision) + (TopicC topic-instance) + (list akos-checked all-checked-topics)) (let ((isas-of-this - (get-direct-types-of-topic topic-instance)) + (get-direct-types-of-topic topic-instance :revision revision)) (akos-of-this - (get-direct-supertypes-of-topic topic-instance)) - (psi-of-this (uri (first (psis topic-instance)))) - (topictype (d:get-item-by-psi json-tmcl-constants::*topictype-psi*)) - (topictype-constraint (is-type-constrained)) + (get-direct-supertypes-of-topic topic-instance :revision revision)) + (psi-of-this (uri (first (psis topic-instance :revision revision)))) + (topictype (get-item-by-psi *topictype-psi* :revision revision)) + (topictype-constraint (is-type-constrained :revision revision)) (local-all-checked-topics all-checked-topics) (local-akos-checked)) - (when (not topictype-constraint) (return-from valid-instance-p (list topic-instance))) - (when (and topictype-constraint (not topictype)) - (error (format nil "From valid-instance-p(): The topic \"~a\" does not exist - please create it or remove the topic \"~a\"" - json-tmcl-constants::*topictype-psi* (d:uri (first (d:psis topictype-constraint)))))) - + (error "From valid-instance-p(): The topic \"~a\" does not exist - please create it or remove the topic \"~a\"" + *topictype-psi* + (uri (first (psis topictype-constraint :revision revision))))) (when (eql topic-instance topictype) - (return-from valid-instance-p (remove-duplicates (append all-checked-topics (list topic-instance))))) - + (return-from valid-instance-p + (remove-duplicates (append all-checked-topics (list topic-instance))))) (unless (or isas-of-this akos-of-this) - (error (format nil "The topic \"~a\" is not a valid topic-instance for any topic-type" psi-of-this))) - + (error "The topic \"~a\" is not a valid topic-instance for any topic-type" + psi-of-this)) (when (find topic-instance akos-checked) (return-from valid-instance-p all-checked-topics)) - (pushnew topic-instance local-all-checked-topics) (pushnew topic-instance local-akos-checked) - (dolist (isa isas-of-this) (handler-case (let ((topics - (topictype-p isa topictype topictype-constraint))) + (topictype-p isa topictype topictype-constraint + nil revision))) (dolist (top topics) (pushnew top local-all-checked-topics))) - (condition (err) (error (format nil "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a" psi-of-this err))))) + (condition (err) (error "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a" + psi-of-this err)))) (dolist (ako akos-of-this) - (when (not (handler-case (let ((topics - (topictype-p ako topictype topictype-constraint all-checked-topics))) + (when (not (handler-case + (let ((topics + (topictype-p ako topictype topictype-constraint + all-checked-topics revision))) (dolist (top topics) (pushnew top local-all-checked-topics)) (pushnew ako local-akos-checked) topics) (condition () nil))) - (handler-case (let ((topics - (valid-instance-p ako akos-checked (append all-checked-topics (list ako))))) + (handler-case + (let ((topics + (valid-instance-p ako akos-checked (append all-checked-topics + (list ako)) revision))) (dolist (top topics) (pushnew top local-all-checked-topics) (pushnew top local-akos-checked)) topics) - (condition (err) (error (format nil "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a" psi-of-this err)))))) + (condition (err) (error "The topic \"~a\" is not a valid topic-instance for any topic-type~%~%~a" + psi-of-this err))))) local-all-checked-topics)) -(defun return-all-tmcl-types () +(defun return-all-tmcl-types (&key (revision *TM-REVISION*)) "Returns all topics that are valid tmcl-types" - (let ((all-topics - (json-exporter::clean-topics - (elephant:get-instances-by-class 'd:TopicC))) - (topictype (get-item-by-psi json-tmcl-constants::*topictype-psi*)) - (topictype-constraint (is-type-constrained))) + (declare (type (or integer null) revision)) + (let ((all-topics (get-all-topics revision)) + (topictype (get-item-by-psi json-tmcl-constants::*topictype-psi* + :revision revision)) + (topictype-constraint (is-type-constrained :revision revision))) (let ((all-types - (remove-if #'null - (map 'list #'(lambda(x) - (handler-case (progn - (topictype-p x topictype topictype-constraint) - x) - (condition () nil))) all-topics)))) + (remove-if + #'null + (map 'list #'(lambda(x) + (handler-case + (progn + (topictype-p x topictype topictype-constraint + nil revision) + x) + (condition () nil))) all-topics)))) (let ((not-abstract-types (remove-if #'null (map 'list #'(lambda(x) - (unless (json-tmcl:abstract-p x) + (unless (abstract-p x :revision revision) x)) all-types)))) not-abstract-types)))) -(defun return-all-tmcl-instances () +(defun return-all-tmcl-instances (&key (revision *TM-REVISION*)) "Returns all topics that are valid instances of any topic type. The validity is only oriented on the typing of topics, e.g. type-instance or supertype-subtype." - (let ((all-topics - (json-exporter::clean-topics - (elephant:get-instances-by-class 'd:TopicC)))) + (declare (type (or integer null) revision)) + (let ((all-topics (get-all-topics revision))) (let ((valid-instances - (remove-if #'null - (map 'list #'(lambda(x) - (handler-case (progn - (valid-instance-p x) - x) - (condition () nil))) all-topics)))) + (remove-if + #'null + (map 'list #'(lambda(x) + (handler-case (progn + (valid-instance-p x nil nil revision) + x) + (condition () nil))) all-topics)))) valid-instances))) -(defun is-type-constrained (&key (what json-tmcl::*topictype-constraint-psi*)) - "Returns nil if there is no type-constraint otherwise the instance of the type-constraint." - (let ((topictype-constraint (d:get-item-by-psi what))) +(defun is-type-constrained (&key (what *topictype-constraint-psi*) + (revision *TM-REVISION*)) + "Returns nil if there is no type-constraint otherwise the instance of + the type-constraint." + (declare (string what) + (type (or integer null) revision)) + (let ((topictype-constraint (get-item-by-psi what :revision revision))) (when topictype-constraint (let ((ttc (remove-duplicates - (remove-if #'null - (remove-if #'(lambda(x) (when (eql topictype-constraint x) - t)) - (get-direct-instances-of-topic topictype-constraint)))))) + (remove-if + #'null + (remove-if #'(lambda(x) (when (eql topictype-constraint x) + t)) + (get-direct-instances-of-topic topictype-constraint + :revision revision)))))) ttc)))) -(defun list-all-supertypes (topic-instance &optional (checked-topics nil)) +(defun list-all-supertypes (topic-instance &optional (checked-topics nil) + (revision *TM-REVISION*)) "Returns all supertypes of the given topic recursively." + (declare (type (or integer null) revision) + (TopicC topic-instance) + (list checked-topics)) (let ((current-checked-topics (append checked-topics (list topic-instance))) - (akos-of-this (get-direct-supertypes-of-topic topic-instance))) + (akos-of-this (get-direct-supertypes-of-topic topic-instance + :revision revision))) (dolist (ako-of-this akos-of-this) (when (not (find ako-of-this current-checked-topics)) (let ((new-checked-topics - (list-all-supertypes ako-of-this current-checked-topics))) + (list-all-supertypes ako-of-this current-checked-topics revision))) (dolist (new-topic new-checked-topics) (pushnew new-topic current-checked-topics))))) current-checked-topics)) -(defun get-all-upper-constrainted-topics (topic) +(defun get-all-upper-constrainted-topics (topic &key (revision *TM-REVISION*)) "Returns all topics that are supertypes or direct types of the given topic-type. So all direct constraints of the found topics are valid constraints for the given one." + (declare (TopicC topic) + (type (or integer null) revision)) ;; find all direct types (let ((direct-isas-of-this - (get-direct-types-of-topic topic))) - + (get-direct-types-of-topic topic :revision revision))) ;; find all supertypes (recursive -> transitive relationship (let ((all-akos-of-this - (list-all-supertypes topic))) + (list-all-supertypes topic nil revision))) (remove-duplicates (union direct-isas-of-this all-akos-of-this))))) \ No newline at end of file Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp (original) +++ trunk/src/model/changes.lisp Sun Oct 10 05:41:19 2010 @@ -7,21 +7,20 @@ ;;+----------------------------------------------------------------------------- -;-*- standard-indent:2; tab-width:2; indent-tabs-mode:nil -*- (in-package :datamodel) (defun get-all-revisions () "Returns an ordered set of the start dates of all revisions in the engine" - ;TODO: this is a very inefficient implementation... it would equally - ;be possible to have a separate object that stored all such - ;revisions and only make the search from the latest version that's - ;stored their - (let - ((revision-set)) + ;TODO: this is a very inefficient implementation... it would equally + ;be possible to have a separate object that stored all such + ;revisions and only make the search from the latest version that's + ;stored their + (let ((revision-set)) (dolist (vi (elephant:get-instances-by-class 'VersionInfoC)) (pushnew (start-revision vi) revision-set)) (sort revision-set #'<))) + (defun get-all-revisions-for-tm (tm-id) "Returns an ordered set of the start dates of all revisions in the engine for this Topic Map" @@ -29,63 +28,86 @@ ((tm (get-item-by-item-identifier tm-id :revision 0)) (tops-and-assocs (when tm (union (topics tm) (associations tm)))) (revision-set nil)) - ;(format t "tops-and-assocs: ~a~&" (mapcan #'versions tops-and-assocs)) (dolist (vi (mapcan #'versions tops-and-assocs)) - ;(format t "(start-revision vi): ~a~&" (start-revision vi)) (pushnew (start-revision vi) revision-set)) (sort revision-set #'<))) -(defun find-associations-for-topic (top) - "find all associations of this topic" - (let - ((type-instance-topic - (d:identified-construct - (elephant:get-instance-by-value 'PersistentIdC - 'uri - "http://psi.topicmaps.org/iso13250/model/type-instance")))) - (remove - type-instance-topic - (remove-duplicates - (map 'list #'parent (player-in-roles top))) - :key #'instance-of))) +(defgeneric find-all-associations (instance &key revision) + (:documentation "Finds all associations for a topic.") + (:method ((instance TopicC) &key (revision *TM-REVISION*)) + (declare (type (or integer null) revision)) + (remove-duplicates + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles instance :revision revision))))) + + +(defgeneric find-associations (instance &key revision) + (:documentation "Finds all associations of this topic except + type-instance-associations.") + (:method ((instance TopicC) &key (revision *TM-REVISION*)) + (declare (type (or integer null) revision)) + (let ((type-instance-topic + (d:identified-construct + (elephant:get-instance-by-value + 'PersistentIdC 'uri *type-instance-psi*)))) + (remove-if + #'(lambda(assoc) + (eql (instance-of assoc :revision revision) + type-instance-topic)) + (find-all-associations instance :revision revision))))) -(defgeneric find-referenced-topics (construct) +(defgeneric find-referenced-topics (construct &key revision) (:documentation "find all the topics that are references from this construct as type, scope or player, as the case may be")) -(defmethod find-referenced-topics ((characteristic CharacteristicC)) - "characteristics are scopable + typable" + +(defmethod find-referenced-topics ((characteristic CharacteristicC) + &key (revision *TM-REVISION*)) + "characteristics are scopable + typable + reifiable" (append - (when (reifier characteristic) - (list (reifier characteristic))) - (themes characteristic) - (when (instance-of-p characteristic) - (list (instance-of characteristic))) + (when (reifier characteristic :revision revision) + (list (reifier characteristic :revision revision))) + (themes characteristic :revision revision) + (when (instance-of characteristic :revision revision) + (list (instance-of characteristic :revision revision))) + (when (and (typep characteristic 'NameC) + (variants characteristic :revision revision)) + (remove-if #'null + (loop for var in (variants characteristic :revision revision) + append (find-referenced-topics var :revision revision)))) (when (and (typep characteristic 'OccurrenceC) (> (length (charvalue characteristic)) 0) (eq #\# (elt (charvalue characteristic) 0))) - (list (get-item-by-id (subseq (charvalue characteristic) 1)))))) + (list (get-item-by-id (subseq (charvalue characteristic) 1) + :revision revision))))) -(defmethod find-referenced-topics ((role RoleC)) +(defmethod find-referenced-topics ((role RoleC) + &key (revision *TM-REVISION*)) (append - (when (reifier role) - (list (reifier role))) - (list (instance-of role)) - (list (player role)))) + (when (reifier role :revision revision) + (list (reifier role :revision revision))) + (list (instance-of role :revision revision)) + (list (player role :revision revision)))) + -(defmethod find-referenced-topics ((association AssociationC)) +(defmethod find-referenced-topics ((association AssociationC) + &key (revision *TM-REVISION*)) "associations are scopable + typable" (append - (when (reifier association) - (list (reifier association))) - (list (instance-of association)) - (themes association) - (mapcan #'find-referenced-topics (roles association)))) + (when (reifier association :revision revision) + (list (reifier association :revision revision))) + (list (instance-of association :revision revision)) + (themes association :revision revision) + (mapcan #'(lambda(role) + (find-referenced-topics role :revision revision)) + (roles association :revision revision)))) -(defmethod find-referenced-topics ((top TopicC)) +(defmethod find-referenced-topics ((top TopicC) + &key (revision *TM-REVISION*)) "Part 1b of the eGov-Share spec states: # for each topicname in T export a topic stub for each scope topic # for each occurrence in T export a topic stub for the occurrence type (if it exists) @@ -98,52 +120,186 @@ (remove top (append - (list-instanceOf top) - (mapcan #'find-referenced-topics (names top)) - (mapcan #'find-referenced-topics (mapcan #'variants (names top))) - (mapcan #'find-referenced-topics (occurrences top)) - (mapcan #'find-referenced-topics (find-associations-for-topic top)))))) + (list-instanceOf top :revision revision) + (mapcan #'(lambda(name) + (find-referenced-topics name :revision revision)) + (names top :revision revision)) + (mapcan #'(lambda(variant) + (find-referenced-topics variant :revision revision)) + (mapcan #'variants (names top :revision revision))) + (mapcan #'(lambda(occ) + (find-referenced-topics occ :revision revision)) + (occurrences top :revision revision)) + (mapcan #'(lambda(assoc) + (find-referenced-topics assoc :revision revision)) + (find-associations top :revision revision)))))) +(defgeneric initial-version-p (version-info) + (:documentation "A helper function for changed-p that returns the passed + version-info object if it is the initial version-info object, + i.e. it owns the smallest start-revsion of the + version-construct.") + (:method ((version-info VersionInfoC)) + (unless (find-if #'(lambda(vi) + (< (start-revision vi) (start-revision version-info))) + (versions (versioned-construct version-info))) + version-info))) + + (defgeneric changed-p (construct revision) - (:documentation "Has the topic map construct changed in a given revision? 'Changed' can mean: + (:documentation "Has the topic map construct changed in a given revision? + 'Changed' can mean: * newly created + * deletion of an element * modified through the addition or removal of identifiers - * (for associations) modified through the addition or removal of identifiers in the association or one of its roles - * (for topics) modified through the addition or removal of identifiers or characteristics - * (for topics) modified through the addition or removal of an association in which it is first player")) + * (for associations) modified through the addition or removal of + identifiers in the association or one of its roles + * (for topics) modified through the addition or removal of identifiers + or characteristics + * (for topics) modified through the addition or removal of an association + in which it is first player")) + (defmethod changed-p ((construct TopicMapConstructC) (revision integer)) - "The 'normal' case: changes only when new identifiers are added" - (find revision (versions construct) :test #'= :key #'start-revision)) + "changed-p returns nil for TopicMapConstructCs that are not specified + more detailed. The actual algorithm is processed for all + VersionedConstructCs." + (declare (ignorable revision)) + nil) -;There is quite deliberately no method specialized on AssociationC as -;copy-item-identifiers for Associations already guarantees that the -;version history of an association is only updated when the -;association itself is really updated - -(defmethod changed-p ((topic TopicC) (revision integer)) - "A topic is changed if one of its child elements (identifiers or -characteristics) or one of the associations in which it is first player has changed" - (let* - ((first-player-in-associations - (remove-if-not - (lambda (association) - (eq (player (first (roles association))) - topic)) - (find-associations-for-topic topic))) - (all-constructs - (union - (get-all-identifiers-of-construct topic) - (union - (names topic) - (union - (occurrences topic) - first-player-in-associations))))) - (some - (lambda (construct) - (changed-p construct revision)) - all-constructs))) + +(defmethod changed-p ((construct PointerC) (revision integer)) + "Returns t if the PointerC was added to a construct the first + time in the passed revision" + (let ((version-info (some #'(lambda(pointer-association) + (changed-p pointer-association revision)) + (slot-p construct 'identified-construct)))) + (when version-info + (initial-version-p version-info)))) + + +(defmethod changed-p ((construct VersionedConstructC) (revision integer)) + "changed-p returns t if there exist a VersionInfoC with the given start-revision." + (let ((version-info + (find revision (versions construct) :test #'= :key #'start-revision))) + (when version-info + (initial-version-p version-info)))) + + +(defmethod changed-p ((construct CharacteristicC) (revision integer)) + "Returns t if the CharacteristicC was added to a construct in the passed + revision or if <ReifiableConstructC> changed." + (or (call-next-method) + (let ((version-info + (some #'(lambda(characteristic-association) + (changed-p characteristic-association revision)) + (slot-p construct 'parent)))) + (when version-info + (initial-version-p version-info))))) + + +(defmethod changed-p ((construct RoleC) (revision integer)) + "Returns t if the RoleC was added to a construct in the passed + revision or if <ReifiableConstructC> changed." + (or (call-next-method) + (let ((version-info + (some #'(lambda(role-association) + (changed-p role-association revision)) + (slot-p construct 'parent)))) + (when version-info + (initial-version-p version-info))))) + + +(defgeneric end-revision-p (construct revision) + (:documentation "A helper function for changed-p. It returns the latest + version-info if the passed versioned-construct was + marked-as-deleted in the version that is given.") + (:method ((construct VersionedConstructC) (revision integer)) + (let ((version-info (find revision (versions construct) + :key #'end-revision :test #'=))) + (when (and version-info + (not + (find-if + #'(lambda(vi) + (or (> (end-revision vi) (end-revision version-info)) + (= (end-revision vi) 0))) + (versions construct)))) + version-info)))) + + +(defmethod changed-p ((construct ReifiableConstructC) (revision integer)) + "Returns t if a ReifiableConstructC changed in the given version, i.e. + an item-identifier or reifier was added to the construct itself." + (or (some #'(lambda(vc) + (changed-p vc revision)) + (union (item-identifiers construct :revision revision) + (let ((reifier-top (reifier construct :revision revision))) + (when reifier-top + (list reifier-top))))) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (union (slot-p construct 'item-identifiers) + (slot-p construct 'reifier))))) + + +(defmethod changed-p ((construct NameC) (revision integer)) + "Returns t if the passed NameC changed in the given version, i.e. + the <ReifiableConstructC> characteristics or the variants changed." + (or (call-next-method) + (some #'(lambda(var) + (changed-p var revision)) + (variants construct :revision revision)) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (slot-p construct 'variants)))) + + +(defmethod changed-p ((construct TopicC) (revision integer)) + "Returns t if the passed TopicC changed in the given version, i.e. + the <ReifiableConstructC>, <PersistentIdC>, <LocatorC>, <NameC>, + <OccurrenceC>, <AssociationC> or the reified-construct changed." + (or (call-next-method) + (some #'(lambda(vc) + (changed-p vc revision)) + (union + (union + (union (psis construct :revision revision) + (locators construct :revision revision)) + (union (names construct :revision revision) + (occurrences construct :revision revision))) + (remove-if-not + (lambda (assoc) + (eq (player (first (roles assoc :revision revision)) + :revision revision) + construct)) + (find-all-associations construct :revision revision)))) + (let ((rc (reified-construct construct :revision revision))) + (when rc + (let ((ra (find-if #'(lambda(reifier-assoc) + (eql (reifiable-construct reifier-assoc) rc)) + (slot-p construct 'reified-construct)))) + (changed-p ra revision)))) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (union (union (union (slot-p construct 'psis) + (slot-p construct 'locators)) + (union (slot-p construct 'names) + (slot-p construct 'occurrences))) + (slot-p construct 'reified-construct))))) + + + +(defmethod changed-p ((construct AssociationC) (revision integer)) + "Returns t if the passed AssociationC changed in the given version, i.e. + the <RoleC> or the <ReifiableConstructC> changed." + (or (call-next-method) + (some #'(lambda(role) + (changed-p role revision)) + (roles construct :revision revision)) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (slot-p construct 'roles)))) (defpclass FragmentC () @@ -191,15 +347,20 @@ cached-fragments (remove nil - (map 'list - (lambda (top) - (when (changed-p top revision) - (make-instance 'FragmentC - :revision revision - :associations (find-associations-for-topic top) ;TODO: this quite probably introduces code duplication with query: Check! - :referenced-topics (find-referenced-topics top) - :topic top))) - (elephant:get-instances-by-class 'TopicC)))))) + (map + 'list + (lambda (top) + (when (changed-p top revision) + (make-instance 'FragmentC + :revision revision + :associations (find-associations + top :revision revision) + ;TODO: this quite probably introduces + ;code duplication with query: Check! + :referenced-topics (find-referenced-topics + top :revision revision) + :topic top))) + (get-all-topics revision)))))) (defun get-fragment (unique-id) "get a fragment by its unique id" @@ -208,79 +369,47 @@ 'unique-id unique-id)) -(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")) - -(defmethod mark-as-deleted ((construct TopicMapConstructC) &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)))) - -(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision) - "Mark an association and its roles as deleted" - (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator)) - (roles ass)) - (call-next-method)) - -(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision) - "Mark a topic as deleted if it comes from the source indicated by -source-locator" - ;;Part 1b, 1.4.3.3.1: - ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F - ;; * Let SI be the value of TopicSI element in ATOM entry E - ;; * feed F contains E - ;; * entry E references topic fragment TF - ;; * Let LTM be the local topic map - ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI - ;; * For all names, occurrences and associations in which T plays a role, TMC - ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC - ;; * Merge in the fragment TF using SP as the base all generated source locators. - - (when - (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top)) - (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator)) - (names top)) - (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator)) - (occurrences top)) - (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator)) - (find-associations-for-topic top)) - (call-next-method))) - (defgeneric add-source-locator (construct &key source-locator revision) (:documentation "adds an item identifier to a given construct based on the source -locator and an internally generated id (ideally a uuid)")) + locator and an internally generated id (ideally a uuid)")) + (defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision) - (declare (ignorable revision)) + (declare (integer revision)) (unless - (some (lambda (ii) (string-starts-with (uri ii) source-locator)) (item-identifiers construct)) + (some (lambda (ii) + (string-starts-with (uri ii) source-locator)) + (item-identifiers construct :revision revision)) (let ((ii-uri (format nil "~a/~d" source-locator (internal-id construct)))) - (make-instance 'ItemIdentifierC :uri ii-uri :identified-construct construct :start-revision revision)))) + (make-construct 'ItemIdentifierC + :uri ii-uri + :identified-construct construct + :start-revision revision)))) + (defmethod add-source-locator ((top TopicC) &key source-locator revision) ;topics already have the source locator in (at least) one PSI, so we ;do not need to add an extra item identifier to them. However, we ;need to do that for all their characteristics + associations - (mapc (lambda (name) (add-source-locator name :revision revision :source-locator source-locator)) - (names top)) - (mapc (lambda (occ) (add-source-locator occ :revision revision :source-locator source-locator)) - (occurrences top)) - (mapc (lambda (ass) (add-source-locator ass :revision revision :source-locator source-locator)) - (find-associations-for-topic top))) + (mapc (lambda (name) + (add-source-locator name :revision revision + :source-locator source-locator)) + (names top :revision revision)) + (mapc (lambda (occ) + (add-source-locator occ :revision revision + :source-locator source-locator)) + (occurrences top :revision revision)) + (mapc (lambda (ass) + (add-source-locator ass :revision revision + :source-locator source-locator)) + (find-associations top :revision revision))) (defun create-latest-fragment-of-topic (topic-psi) "Returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) - (let ((topic - (get-item-by-psi topic-psi))) + (let ((topic (get-latest-topic-by-psi topic-psi))) (when topic (let ((start-revision (start-revision @@ -297,16 +426,17 @@ existing-fragment (make-instance 'FragmentC :revision start-revision - :associations (find-associations-for-topic topic) - :referenced-topics (find-referenced-topics topic) + :associations (find-associations + topic :revision start-revision) + :referenced-topics (find-referenced-topics + topic :revision start-revision) :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))) + (let ((topic (get-latest-topic-by-psi topic-psi))) (when topic (let ((existing-fragments (elephant:get-instances-by-value 'FragmentC 'topic topic))) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Oct 10 05:41:19 2010 @@ -7,510 +7,1072 @@ ;;+----------------------------------------------------------------------------- -;-*- standard-indent: 2; indent-tabs-mode: nil -*- (defpackage :datamodel (:use :cl :elephant :constants) (:nicknames :d) (:import-from :exceptions - missing-reference-error - no-identifier-error - duplicate-identifier-error - object-not-found-error) - (:export :AssociationC ;; types - :CharacteristicC - :FragmentC - :IdentifierC - :IdentityC - :ItemIdentifierC - :NameC - :OccurrenceC - :PersistentIdC - :ReifiableConstructC - :RoleC - :ScopableC - :SubjectLocatorC - :TopicC - :TopicIdentificationC - :TopicMapC - :TopicMapConstructC + duplicate-identifier-error + object-not-found-error + missing-argument-error + not-mergable-error + tm-reference-error) + (:import-from :constants + *xml-string* + *instance-psi*) + (:export ;;classes + :TopicMapConstructC + :VersionedConstructC + :ReifiableConstructC + :ScopableC :TypableC + :TopicMapC + :AssociationC + :RoleC + :CharacteristicC + :OccurrenceC + :NameC :VariantC - - ;; functions and slot accessors - :in-topicmaps - :add-to-topicmap - :add-source-locator - :associations - :changed-p - :charvalue - :check-for-duplicate-identifiers - :datatype - :equivalent-constructs - :find-item-by-revision - :find-most-recent-revision - :get-all-revisions - :get-all-revisions-for-tm - :get-fragment - :get-fragments - :get-revision - :get-item-by-content - :get-item-by-id - :get-item-by-item-identifier - :get-item-by-psi - :identified-construct - :identified-construct-p - :in-topicmap - :internal-id - :instance-of - :instance-of-p - :item-identifiers - :item-identifiers-p - :list-instanceOf - :list-super-types - :locators - :locators-p - :make-construct - :mark-as-deleted - :names - :namevalue - :occurrences - :name - :parent - :player - :player-in-roles - :players - :psis - :psis-p - :referenced-topics - :revision - :RoleC-p - :roleid - :roles - :themes - :xtm-id - :xtm-id-p - :topic - :topicid - :topic-identifiers - :topics - :unique-id - :uri - :uri-p + :PointerC + :IdentifierC + :PersistentIdC + :ItemIdentifierC + :SubjectLocatorC + :TopicIdentificationC + :TopicC + :FragmentC + + ;;methods, functions and macros + :xtm-id + :uri + :identified-construct + :item-identifiers + :add-item-identifier + :delete-item-identifier + :reifier + :add-reifier + :delete-reifier + :find-item-by-revision + :find-most-recent-revision + :themes + :add-theme + :delete-theme + :instance-of + :add-type + :delete-type + :parent + :add-parent + :delete-parent + :variants + :add-variant + :delete-variant + :player + :add-player + :delete-player + :roles + :add-role + :delete-role + :associations + :topics + :add-to-tm + :delete-from-tm + :psis + :add-psi + :delete-psi + :topic-identifiers + :add-topic-identifier + :delete-topic-identifier + :topic-id + :locators + :add-locator + :delete-locator + :names + :add-name + :delete-name + :occurrences + :add-occurrence + :delete-occurrence + :player-in-roles :used-as-type :used-as-theme - :variants - :xor - :create-latest-fragment-of-topic + :datatype + :charvalue + :reified-construct + :mark-as-deleted + :marked-as-deleted-p + :in-topicmaps + :delete-construct + :get-revision + :get-item-by-id + :get-item-by-psi + :get-item-by-item-identifier + :get-item-by-locator + :get-item-by-content + :string-integer-p + :with-revision :get-latest-fragment-of-topic - :reified - :reifier - :add-reifier - :remove-reifier - - :*current-xtm* ;; special variables - :*TM-REVISION* + :create-latest-fragment-of-topic + :PointerC-p + :IdentifierC-p + :SubjectLocatorC-p + :PersistentIdC-p + :ItemIdentifierC-p + :TopicIdentificationC-p + :CharacteristicC-p + :OccurrenceC-p + :NameC-p + :VariantC-p + :ScopableC-p + :TypableC-p + :TopicC-p + :AssociationC-p + :RoleC-p + :TopicMapC-p + :ReifiableConstructC-p + :TopicMapConstructC-p + :VersionedConstructC-p + :make-construct + :list-instanceOf + :list-super-types + :in-topicmap + :string-starts-with + :get-fragments + :get-fragment + :get-all-revisions + :unique-id + :topic + :referenced-topics + :revision + :get-all-revisions-for-tm + :add-source-locator + :changed-p + :check-for-duplicate-identifiers + :find-item-by-content + :rec-remf + :get-all-topics + :get-all-associations + :get-all-tms + + + ;;globals + :*TM-REVISION* + :*CURRENT-XTM*)) - :with-revision ;;macros +(in-package :datamodel) - :string-starts-with ;;helpers - )) -(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0))) -(in-package :datamodel) +;;TODO: implement a macro with-merge-constructs, that merges constructs +;; after all operations in the body were called -(defparameter *current-xtm* nil "Represents the currently active TM") -(defmacro find-max-elem (candidate-list &key (relop #'> relop-p) (key #'identity key-p)) - "Given a non-empty list, return the maximum element in the list. - If provided, then relop must be a relational operator that determines the ordering; - else #'> is used. The keyword parameter key may name a function that is used to extract - the sort key; otherwise the elements themselves are the sort keys." - (let - ((candidate-list-value-name (gensym)) - (relop-value-name (gensym)) - (key-value-name (gensym)) - (best-seen-cand-name (gensym)) - (max-key-name (gensym)) - (inspected-cand-name (gensym)) - (inspected-key-name (gensym))) - (let - ((max-key-init (if key-p - `(funcall ,key-value-name ,best-seen-cand-name) - best-seen-cand-name)) - (inspected-key-init (if key-p - `(funcall ,key-value-name ,inspected-cand-name) - inspected-cand-name)) - (relexp (if relop-p - `(funcall ,relop-value-name ,inspected-key-name ,max-key-name) - `(> ,inspected-key-name ,max-key-name)))) - (let - ((initializers `((,candidate-list-value-name ,candidate-list) - (,best-seen-cand-name (first ,candidate-list-value-name)) - (,max-key-name ,max-key-init)))) - (when relop-p - (push `(,relop-value-name ,relop) initializers)) - (when key-p - (push `(,key-value-name ,key) initializers)) - `(let* - ,initializers - (dolist (,inspected-cand-name (rest ,candidate-list-value-name)) - (let - ((,inspected-key-name ,inspected-key-init)) - (when ,relexp - (setf ,best-seen-cand-name ,inspected-cand-name) - (setf ,max-key-name ,inspected-key-name)))) - ,best-seen-cand-name))))) +;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *TM-REVISION* 0) + +(defparameter *CURRENT-XTM* nil "Represents the currently active TM.") + + +;;; classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; versioning +(defpclass VersionInfoC() + ((start-revision :initarg :start-revision + :accessor start-revision + :type integer + :initform 0 + :documentation "The start-revision of the version's + interval of a versioned object.") + (end-revision :initarg :end-revision + :accessor end-revision + :type integer + :initform 0 + :documentation "The end-revision of the version's interval + of a versioned object.") + (versioned-construct :initarg :versioned-construct + :accessor versioned-construct + :associate VersionedConstructC + :documentation "The reference of the versioned + object that is described by this + VersionInfoC-object.")) + (:documentation "A VersionInfoC-object describes the revision information + of a versioned object in intervals starting by the value + start-revision and ending by the value end-revision - 1. + end-revision=0 means always the latest version.")) + + +(defpclass VersionedConstructC() + ((versions :initarg :versions + :accessor versions + :inherit t + :associate (VersionInfoC versioned-construct) + :documentation "Version infos for former versions of this base + class."))) + + +;;; base classes ... +(defpclass TopicMapConstructC() + () + (:documentation "An abstract base class for all classes that describes + Topic Maps data.")) + + +(defpclass ScopableC() + ((themes :associate (ScopeAssociationC scopable-construct) + :inherit t + :documentation "Contains all association-objects that contain the + actual scope-topics.")) + (:documentation "An abstract base class for all constructs that are scoped.")) + + +(defpclass TypableC() + ((instance-of :associate (TypeAssociationC typable-construct) + :inherit t + :documentation "Contains all association-objects that contain + the actual type-topic.")) + (:documentation "An abstract base class for all typed constructcs.")) + + +(defpclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :initform constants:*xml-string* + :type string + :index t + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef).")) + (:documentation "An abstract base class for characteristics that own + an xml-datatype.")) + + +;;; pointers ... +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error (make-missing-argument-condition "From PointerC(): uri must be set for a pointer" 'uri ':uri)) + :index t + :documentation "The actual value of a pointer, i.e. uri or ID.") + (identified-construct :associate (PointerAssociationC identifier) + :inherit t + :documentation "Associates a association-object that + additionally stores some + version-infos.")) + (:documentation "An abstract base class for all pointers.")) + + +(defpclass IdentifierC(PointerC) + () + (:documentation "An abstract base class for all TM-Identifiers.")) + + +(defpclass TopicIdentificationC(PointerC) + ((xtm-id :initarg :xtm-id + :accessor xtm-id + :type string + :initform (error (make-missing-argument-condition "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier" 'xtm-id ':xtm-id)) + :index t + :documentation "ID of the TM this identification came from.")) + (:index t) + (:documentation "Identify topic items through generalized topic-ids. + A topic may have many original topicids, the class + representing one of them.")) + + +(defpclass SubjectLocatorC(IdentifierC) + () + (:index t) + (:documentation "A subject-locator that contains an uri-value and an + association to SubjectLocatorAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass PersistentIdC(IdentifierC) + () + (:index t) + (:documentation "A subject-identifier that contains an uri-value and an + association to PersistentIdAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t) + (:documentation "An item-identifier that contains an uri-value and an + association to ItemIdAssociationC's which are in turn + associated with RiefiableConstructC's.")) + + +;;; reifiables ... +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :associate (ItemIdAssociationC parent-construct) + :inherit t + :documentation "A relation to all item-identifiers of + this construct.") + (reifier :associate (ReifierAssociationC reifiable-construct) + :inherit t + :documentation "A relation to a reifier-topic.")) + (:documentation "Reifiable constructs as per TMDM.")) + + +(defpclass AssociationC(ReifiableConstructC ScopableC TypableC + VersionedConstructC) + ((roles :associate (RoleAssociationC parent-construct) + :documentation "Contains all association-objects of all roles this + association contains.") + (in-topicmaps :associate (TopicMapC associations) + :many-to-many t + :documentation "List of all topic maps this association is + part of")) + (:index t) + (:documentation "Association in a Topic Map")) + + +(defpclass RoleC(ReifiableConstructC TypableC) + ((parent :associate (RoleAssociationC role) + :documentation "Associates this object with a role-association.") + (player :associate (PlayerAssociationC parent-construct) + :documentation "Associates this object with a player-association."))) + + +(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC) + ((topics :associate (TopicC in-topicmaps) + :many-to-many t + :accessor topics + :documentation "List of topics that explicitly belong to this TM.") + (associations :associate (AssociationC in-topicmaps) + :many-to-many t + :accessor associations + :documentation "List of associations that belong to this TM.")) + (:documentation "Represnets a topic map.")) + + +(defpclass TopicC (ReifiableConstructC VersionedConstructC) + ((topic-identifiers :associate (TopicIdAssociationC parent-construct) + :documentation "Contains all association objects that + relate a topic with its actual + topic-identifiers.") + (psis :associate (PersistentIdAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual psis.") + (locators :associate (SubjectLocatorAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual subject-lcoators.") + (names :associate (NameAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual names.") + (occurrences :associate (OccurrenceAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual occurrences.") + (player-in-roles :associate (PlayerAssociationC player-topic) + :documentation "Contains all association objects that relate + a topic that is a player with its role.") + (used-as-type :associate (TypeAssociationC type-topic) + :documentation "Contains all association objects that relate a + topic that is a type with its typable obejct.") + (used-as-theme :associate (ScopeAssociationC theme-topic) + :documentation "Contains all association objects that relate a + topic that is a theme with its scoppable + object.") + (reified-construct :associate (ReifierAssociationC reifier-topic) + :documentation "Contains all association objects that + relate a topic that is a reifier with + its reified object.") + (in-topicmaps :associate (TopicMapC topics) + :many-to-many t + :documentation "List of all topic maps this topic is part of.")) + (:index t) + (:documentation "Represents a TM topic.")) + + + +;;; characteristics ... +(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) + ((parent :associate (CharacteristicAssociationC characteristic) + :inherit t + :documentation "Assocates the characterist obejct with the + parent-association.") + (charvalue :initarg :charvalue + :accessor charvalue + :type string + :inherit t + :initform "" + :index t + :documentation "Contains the actual data of this object.")) + (:documentation "Scoped characteristic of a topic (meant to be used + as an abstract class).")) + + +(defpclass OccurrenceC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM occurrence.")) + + +(defpclass NameC(CharacteristicC) + ((variants :associate (VariantAssociationC parent-construct) + :documentation "Associates this obejct with varian-associations.")) + (:documentation "Scoped name of a topic.")) + + +(defpclass VariantC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM variant.")) + + +;;; versioned associations ... +(defpclass VersionedAssociationC(VersionedConstructC) + () + (:documentation "An abstract base class for all versioned associations.")) + + +(defpclass TypeAssociationC(VersionedAssociationC) + ((type-topic :initarg :type-topic + :accessor type-topic + :initform (error (make-missing-argument-condition "From TypeAssociationC(): type-topic must be set" 'type-topic ':type-topic)) + :associate TopicC + :documentation "Associates this object with a topic that is used + as type.") + (typable-construct :initarg :typable-construct + :accessor typable-construct + :initform (error (make-missing-argument-condition "From TypeAssociationC(): typable-construct must be set" 'typable-construct ':typable-construct)) + :associate TypableC + :documentation "Associates this object with the typable + construct that is typed by the + type-topic.")) + (:documentation "This class associates topics that are used as type for + typable constructcs. Additionally there are stored some + version-infos.")) + + +(defpclass ScopeAssociationC(VersionedAssociationC) + ((theme-topic :initarg :theme-topic + :accessor theme-topic + :initform (error (make-missing-argument-condition "From ScopeAssociationC(): theme-topic must be set" 'theme-topic ':theme-topic)) + :associate TopicC + :documentation "Associates this opbject with a topic that is a + scopable construct.") + (scopable-construct :initarg :scopable-construct + :accessor scopable-construct + :initform (error (make-missing-argument-condition "From ScopeAssociationC(): scopable-construct must be set" 'scopable-construct ':scopable-construct)) + :associate ScopableC + :documentation "Associates this object with the socpable + construct that is scoped by the + scope-topic.")) + (:documentation "This class associates topics that are used as scope with + scopable construtcs. Additionally there are stored some + version-infos")) + + +(defpclass ReifierAssociationC(VersionedAssociationC) + ((reifiable-construct :initarg :reifiable-construct + :accessor reifiable-construct + :initform (error (make-missing-argument-condition "From ReifierAssociation(): reifiable-construct must be set" 'reifiable-construct ':reifiable-construct)) + :associate ReifiableConstructC + :documentation "The actual construct which is reified + by a topic.") + (reifier-topic :initarg :reifier-topic + :accessor reifier-topic + :initform (error (make-missing-argument-condition "From ReifierAssociationC(): reifier-topic must be set" 'reifier-topic ':reifier-topic)) + :associate TopicC + :documentation "The reifier-topic that reifies the + reifiable-construct.")) + (:documentation "A versioned-association that relates a reifiable-construct + with a topic.")) + + +;;; pointer associations ... +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :inherit t + :initform (error (make-missing-argument-condition "From PointerAssociationC(): identifier must be set" 'identifier ':identifier)) + :associate PointerC + :documentation "The actual data that is associated with + the pointer-association's parent.")) + (:documentation "An abstract base class for all versioned + pointer-associations.")) + + +(defpclass SubjectLocatorAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error (make-missing-argument-condition "From SubjectLocatorAssociationC(): parent-construct must be set" 'parent-construct ':parent-symbol)) + :associate TopicC + :documentation "The actual topic which is associated + with the subject-locator.")) + (:documentation "A pointer that associates subject-locators, versions + and topics.")) + + +(defpclass PersistentIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error (make-missing-argument-condition "From PersistentIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :associate TopicC + :documentation "The actual topic which is associated + with the subject-identifier/psi.")) + (:documentation "A pointer that associates subject-identifiers, versions + and topics.")) + + +(defpclass TopicIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error (make-missing-argument-condition "From TopicIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :associate TopicC + :documentation "The actual topic which is associated + with the topic-identifier.")) + (:documentation "A pointer that associates topic-identifiers, versions + and topics.")) + + +(defpclass ItemIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error (make-missing-argument-condition "From ItemIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :associate ReifiableConstructC + :documentation "The actual parent which is associated + with the item-identifier.")) + (:documentation "A pointer that associates item-identifiers, versions + and reifiable-constructs.")) + + +;;; characteristic associations ... +(defpclass CharacteristicAssociationC(VersionedAssociationC) + ((characteristic :initarg :characteristic + :accessor characteristic + :inherit t + :initform (error (make-missing-argument-condition "From CharacteristicCAssociation(): characteristic must be set" 'characteristic ':characteristic)) + :associate CharacteristicC + :documentation "Associates this object with the actual + characteristic object.")) + (:documentation "An abstract base class for all association-objects that + associates characteristics with topics.")) + + +(defpclass VariantAssociationC(CharacteristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error (make-missing-argument-condition "From VariantAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :associate NameC + :documentation "Associates this object with a name.")) + (:documentation "Associates variant objects with name obejcts. + Additionally version-infos are stored.")) + + +(defpclass NameAssociationC(CharacteristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error (make-missing-argument-condition "From NameAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :associate TopicC + :documentation "Associates this object with a topic.")) + (:documentation "Associates name objects with their parent topics. + Additionally version-infos are stored.")) + + +(defpclass OccurrenceAssociationC(CharacteristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error (make-missing-argument-condition "From OccurrenceAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :associate TopicC + :documentation "Associates this object with a topic.")) + (:documentation "Associates occurrence objects with their parent topics. + Additionally version-infos are stored.")) + + +;;; roles/association associations ... +(defpclass PlayerAssociationC(VersionedAssociationC) + ((player-topic :initarg :player-topic + :accessor player-topic + :associate TopicC + :initform (error (make-missing-argument-condition "From PlayerAssociationC(): player-topic must be set" 'player-topic ':player-topic)) + :documentation "Associates this object with a topic that is + a player.") + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate RoleC + :initform (error (make-missing-argument-condition "From PlayerAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :documentation "Associates this object with the parent-association.")) + (:documentation "This class associates roles and their player in given + revisions.")) + + +(defpclass RoleAssociationC(VersionedAssociationC) + ((role :initarg :role + :accessor role + :associate RoleC + :initform (error (make-missing-argument-condition "From RoleAssociationC(): role must be set" 'role ':role)) + :documentation "Associates this objetc with a role-object.") + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate AssociationC + :initform (error (make-missing-argument-condition "From RoleAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct)) + :documentation "Assocates thius object with an + association-object.")) + (:documentation "Associates roles with assoications and adds some + version-infos between these realtions.")) + + +;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun make-duplicate-identifier-condition (message uri) + "Returns an duplicate-identifier-condition with the passed arguments." + (make-condition 'duplicate-identifier-error + :message message + :uri uri)) + + +(defun make-object-not-found-condition (message) + "Returns an object-not-found-condition with the passed arguments." + (make-condition 'object-not-found-error + :message message)) + + +(defun make-tm-reference-condition (message referenced-construct + existing-reference new-reference) + "Returns a tm-reference-condition with the passed arguments." + (make-condition 'tm-reference-error + :message message + :referenced-construct referenced-construct + :existing-reference existing-reference + :new-reference new-reference)) + + +(defun make-not-mergable-condition (message construct-1 construct-2) + "Returns a not-mergable-condition with the passed arguments." + (make-condition 'not-mergable-error + :message message + :construct-1 construct-1 + :construct-2 construct-2)) + + +(defun make-missing-argument-condition (message argument-symbol function-symbol) + "Returns a missing-argument-condition with the passed arguments." + (make-condition 'missing-argument-error + :message message + :argument-symbol argument-symbol + :function-symbol function-symbol)) + + +(defgeneric get-most-recent-versioned-assoc (construct slot-symbol) + (:documentation "Returns the most recent VersionedAssociationC + object.") + (:method ((construct TopicMapConstructC) (slot-symbol Symbol)) + (let ((all-assocs (slot-p construct slot-symbol))) + (let ((zero-assoc + (find-if #'(lambda(assoc) + (= (end-revision + (get-most-recent-version-info assoc)) 0)) + all-assocs))) + (if zero-assoc + zero-assoc + (let ((ordered-assocs + (sort all-assocs + #'(lambda(x y) + (> (end-revision + (get-most-recent-version-info x)) + (end-revision + (get-most-recent-version-info y))))))) + (when ordered-assocs + (first ordered-assocs)))))))) + + +(defun get-latest-topic-by-psi (topic-psi) + "Returns the latest topic bound to the PersistentIdC + object corresponding to the given uri." + (declare (String topic-psi)) + (let ((psi-inst + (elephant:get-instance-by-value + 'PersistentIdC 'uri topic-psi))) + (let ((latest-va + (get-most-recent-versioned-assoc + psi-inst 'identified-construct))) + (when (and latest-va (versions latest-va)) + (identified-construct + psi-inst :revision (start-revision (first (versions latest-va)))))))) + + +(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) + "Returns all instances of the given type and the given revision that are + stored in the db." + (declare (symbol class-symbol) (type (or null integer) revision)) + (let ((db-instances (elephant:get-instances-by-class class-symbol))) + (let ((filtered-instances (remove-if-not #'(lambda(inst) + (typep inst class-symbol)) + db-instances))) + (if revision + (remove-if #'null + (map 'list #'(lambda(inst) + (find-item-by-revision inst revision)) + filtered-instances)) + filtered-instances)))) + + +(defun get-all-topics (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicC :revision revision)) + + +(defun get-all-associations (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'AssociationC :revision revision)) + + +(defun get-all-tms (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicMapC :revision revision)) + + +(defun find-version-info (versioned-constructs + &key (sort-function #'<) (sort-key 'start-revision)) + "Returns all version-infos sorted by the function sort-function which is + applied on the slot sort-key." + (declare (list versioned-constructs)) + (let ((vis + (sort + (loop for vc in versioned-constructs + append (versions vc)) + sort-function :key sort-key))) + (when vis + (first vis)))) + + +(defun rec-remf (plist keyword) + "Calls remf for the past plist with the given keyword until + all key-value-pairs corresponding to the passed keyword were removed." + (declare (list plist) (keyword keyword)) + (loop while (getf plist keyword) + do (remf plist keyword)) + plist) + + +(defun get-item-by-content (content &key (revision *TM-REVISION*)) + "Finds characteristics by their (atomic) content." + (flet + ((get-existing-instances (class-symbol) + (delete-if-not + #'(lambda (constr) + (find-item-by-revision constr revision)) + (elephant:get-instances-by-value class-symbol 'charvalue content)))) + (nconc (get-existing-instances 'OccurenceC) + (get-existing-instances 'NameC) + (get-existing-instances 'VariantC)))) + + (defmacro with-revision (revision &rest body) `(let - ((*TM-REVISION* ,revision)) - ;(format t "*TM-REVISION* is ~a~&" *TM-REVISION*) - ,@body)) - + ((*TM-REVISION* ,revision)) + ,@body)) -(defmacro slot-predicate (instance slot) - (let - ((inst-name (gensym)) - (slot-name (gensym))) - `(let - ((,inst-name ,instance) - (,slot-name ,slot)) - (and (slot-boundp ,inst-name ,slot-name) - (slot-value ,inst-name ,slot-name))))) -(defmacro delete-1-n-association (instance slot) - (let - ((inst-name (gensym)) - (slot-name (gensym))) - `(let - ((,inst-name ,instance) - (,slot-name ,slot)) - (when (slot-predicate ,inst-name ,slot-name) - (elephant:remove-association ,inst-name ,slot-name (slot-value ,inst-name ,slot-name)))))) +(defun slot-p (instance slot-symbol) + "Returns t if the slot depending on slot-symbol is bound and not nil." + (if (slot-boundp instance slot-symbol) + (let ((value (slot-value instance slot-symbol))) + (when value + value)) + ;elephant-relations are handled separately, since slot-boundp does not + ;work here + (handler-case (let ((value (slot-value instance slot-symbol))) + (when value + value)) + (error () nil)))) + + +(defun delete-1-n-association(instance slot-symbol) + (when (slot-p instance slot-symbol) + (remove-association + instance slot-symbol (slot-value instance slot-symbol)))) -(defun xor (a1 a2) - (and (or a1 a2) (not (and a1 a2))) - ) -(defun remove-nil-values (plist) - (let - ((result nil)) - (do* ((rest plist (cddr rest)) - (key (first rest) (first rest)) - (val (second rest) (second rest))) - ((null rest)) - (when val - (pushnew val result) - (pushnew key result))) - result)) +(defgeneric delete-construct (construct) + (:documentation "Drops recursively construct and all its dependent objects + from the elephant store.")) + + +(defmethod delete-construct ((construct elephant:persistent)) + nil) + + +(defmethod delete-construct :after ((construct elephant:persistent)) + (drop-instance construct)) + + +(defun filter-slot-value-by-revision (construct slot-symbol + &key (start-revision + 0 start-revision-provided-p)) + (declare (symbol slot-symbol) (integer start-revision)) + (let ((revision + (cond (start-revision-provided-p + start-revision) + ((boundp '*TM-REVISION*) + *TM-REVISION*) + (t 0))) + (properties (slot-p construct slot-symbol))) + (cond ((not properties) + nil) ;no properties were found -> nil + ((= 0 revision) + (remove-if #'null + (map 'list #'find-most-recent-revision properties))) + (t + (remove-if #'null + (map 'list #'(lambda(prop) + (find-item-by-revision prop revision)) + properties)))))) + (defun get-revision () "TODO: replace by something that does not suffer from a 1 second resolution." (get-universal-time)) -(defgeneric delete-construct (construct) - (:documentation "drops recursively construct and all its dependent objects from the elephant store")) -(defmethod delete-construct ((construct elephant:persistent)) - nil) +(defun string-integer-p (integer-as-string) + "Returns t if the passed string can be parsed to an integer." + (handler-case (when (parse-integer integer-as-string) + t) + (condition () nil))) -(defmethod delete-construct :after ((construct elephant:persistent)) - (elephant:drop-instance construct)) -(defgeneric find-all-equivalent (construct) - (:method ((construct t)) nil) - (:documentation "searches an existing object that is equivalent (but not identical) to construct")) - - -;;;;;;;;;;;;;; -;; -;; VersionInfoC - - -(elephant:defpclass VersionInfoC () - ((start-revision :accessor start-revision - :initarg :start-revision - :type integer - :initform 0 ;TODO: for now - :documentation "The first revison this AssociationC instance is associated with.") - (end-revision :accessor end-revision - :initarg :end-revision - :type integer - :initform 0 ;TODO: for now - :documentation "The first revison this AssociationC instance is no longer associated with.") - (versioned-construct :associate TopicMapConstructC - :accessor versioned-construct - :initarg :versioned-construct - :documentation "reifiable construct that is described by this info")) - (:documentation "Version Info for individual revisions")) - -(defgeneric versioned-construct-p (vi) - (:documentation "t if this version info is already bound to a TM construct") - (:method ((vi VersionInfoC)) (slot-predicate vi 'versioned-construct))) - -(defmethod delete-construct :before ((vi VersionInfoC)) - (delete-1-n-association vi 'versioned-construct)) - -(defgeneric get-most-recent-version-info (construct)) - - -;;;;;;;;;;;;;; -;; -;; ItemIdentifierC +(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*)) + "Merges all constructs contained in the given list." + (declare (list constructs-to-be-merged)) + (cond ((null constructs-to-be-merged) + nil) + ((= (length constructs-to-be-merged) 1) + (first constructs-to-be-merged)) + (t + (let ((constr-1 (first constructs-to-be-merged)) + (constr-2 (second constructs-to-be-merged)) + (tail (subseq constructs-to-be-merged 2))) + (let ((merged-constr + (merge-constructs constr-1 constr-2 :revision revision))) + (merge-all-constructs (append (list merged-constr) + tail))))))) -(elephant:defpclass ItemIdentifierC (IdentifierC) - () - (:index t) - (:documentation "Represents an item identifier")) +(defgeneric internal-id (construct) + (:documentation "Returns the internal id that uniquely identifies a + construct (currently simply its OID).")) -;;;;;;;;;;;;;; -;; -;; SubjectLocator -(elephant:defpclass SubjectLocatorC (IdentifierC) - ((identified-construct :accessor identified-construct - :initarg :identified-construct - :associate TopicC)) - (:index t) - (:documentation "Represents a subject locator")) +(defmethod internal-id ((construct TopicMapConstructC)) + (slot-value construct (find-symbol "OID" 'elephant))) + +(defun string-starts-with (str prefix) + "Checks if string str starts with a given prefix." + (declare (string str prefix)) + (string= str prefix :start1 0 :end1 + (min (length prefix) + (length str)))) -;;;;;;;;;;;;;; -;; -;; IdentifierC -(elephant:defpclass IdentifierC (PointerC) - () - (:documentation "Abstract base class for ItemIdentifierC and - PersistentIdC, primarily in view of the equality rules")) +;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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")) -;;;;;;;;;;;;;; -;; -;; PointerC - -(elephant:defpclass PointerC (TopicMapConstructC) - ((uri :accessor uri - :initarg :uri - :type string - :initform (error "The uri must be set for a pointer") - :index t) - (identified-construct :accessor identified-construct - :initarg :identified-construct - :associate ReifiableConstructC)) - (:documentation "Abstract base class for all types of pointers and identifiers")) +(defgeneric marked-as-deleted-p (construct) + (:documentation "Returns t if the construct was marked-as-deleted.")) -(defmethod delete-construct :before ((construct PointerC)) - (delete-1-n-association construct 'identified-construct)) -(defmethod find-all-equivalent ((construct PointerC)) - (delete construct - (elephant:get-instances-by-value (class-of construct) - 'uri - (uri construct)) - :key #'internal-id)) -(defgeneric uri-p (construct) - (:documentation "Check if the slot uri is bound in an identifier and not nil") - (:method ((identifier PointerC)) (slot-predicate identifier 'uri))) - -(defgeneric identified-construct-p (construct) - (:documentation "Check if the slot identified-construct is bound in an identifier and not nil") - (:method ((identifier PointerC)) (slot-predicate identifier 'identified-construct))) - -(defmethod print-object ((identifier PointerC) stream) - (format stream - "~a(href: ~a; Construct: ~a)" - (class-name (class-of identifier)) - (if (uri-p identifier) - (uri identifier) - "URI UNDEFINED") - (if (identified-construct-p identifier) - (identified-construct identifier) - "SLOT UNBOUND"))) - -(defmethod equivalent-constructs ((identifier1 PointerC) (identifier2 PointerC)) - (string= (uri identifier1) (uri identifier2))) - -(defmethod initialize-instance :around ((identifier PointerC) &key - (start-revision (error "Start revision must be present") ) - (end-revision 0)) - (call-next-method) - (add-to-version-history identifier - :start-revision start-revision - :end-revision end-revision) - identifier) - - -;;;;;;;;;;;;;; -;; -;; TopicMapConstrucC - - -(elephant:defpclass TopicMapConstructC () - ((versions :associate (VersionInfoC versioned-construct) - :accessor versions - :initarg :versions - :documentation "version infos for former versions of this reifiable construct"))) - - ;TODO: if, one day, we allow merges of already existing constructs, we'll need - ;a tree of predecessors rather then just a list of versions. A case in point - ;may be if a newly imported topic carries the PSIs of two existing topics, - ;thereby forcing a merge post factum" - -(defmethod delete-construct :before ((construct TopicMapConstructC)) - (dolist (versioninfo (versions construct)) - (delete-construct versioninfo))) +(defgeneric find-self-or-equal (construct parent-construct &key revision) + (:documentation "Returns the construct 'construct' if is owned by the + parent-construct or an equal construct or nil if there + is no equal one.")) -(defgeneric add-to-version-history (construct &key start-revision end-revision) - (:documentation "Add version history to a topic map construct")) +(defgeneric merge-if-equivalent (new-characteristic parent-construct + &key revision) + (:documentation "Merges the new characteristic/role with one equivalent of the + parent's charateristics/roles instead of adding the entire new + characteristic/role to the parent.")) -(defmethod add-to-version-history ((construct TopicMapConstructC) - &key - (start-revision (error "Start revision must be present") ) - (end-revision 0)) - "Adds relevant information to a construct's version info" - (let - ((current-version-info - (get-most-recent-version-info construct))) - (cond - ((and current-version-info - (= (end-revision current-version-info) start-revision)) ;the item was just marked as deleted - (setf (end-revision current-version-info) 0) ;just revitalize it, do not create a new version - current-version-info) ;TODO: this is not quite correct, the topic - ;might be recreated with new item - ;identifiers. Consider adding a new parameter - ;"revitalize" - ((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 revision (constr) - (:documentation "Essentially a convenience method for start-revision")) - -(defmethod revision ((constr TopicMapConstructC)) - (start-revision constr)) - -(defmethod (setf revision) ((constr TopicMapConstructC) (revision integer)) - (setf (start-revision constr) revision)) - - -(defgeneric find-item-by-revision (constr revision) - (:documentation "Get a given version of a construct (if any, nil if none can be found)")) - -(defmethod find-item-by-revision ((constr TopicMapConstructC) (revision integer)) - (cond - ((= revision 0) - (find-most-recent-revision constr)) - (t - (when (find-if - (lambda(version) - (and (>= revision (start-revision version)) - (or - (< revision (end-revision version)) - (= 0 (end-revision version))))) - (versions constr)) - constr)))) -(defgeneric find-most-recent-revision (construct) - (:documentation "Get the most recent version of a construct (nil if -the construct doesn't have versions yet or not anymore)")) +(defgeneric parent (construct &key revision) + (:documentation "Returns the parent construct of the passed object that + corresponds with the given revision. The returned construct + can be a TopicC or a NameC.")) + + +(defgeneric delete-if-not-referenced (construct) + (:documentation "Calls delete-construct for the given object if it is + not referenced by any other construct.")) + + +(defgeneric add-characteristic (construct characteristic &key revision) + (:documentation "Adds the passed characterisitc to the given topic by calling + add-name or add-occurrences. + Variants are added to names by calling add-name.")) + + +(defgeneric private-delete-characteristic (construct characteristic &key revision) + (:documentation "Deletes the passed characteristic of the given topic by + calling delete-name or delete-occurrence. + Variants are deleted from names by calling delete-variant.")) + + +(defgeneric delete-characteristic (construct characteristic &key revision) + (:documentation "See private-delete-characteristic but adds the parent + (if it is a variant also the parent's parent) to the + version history of this call's revision")) + + +(defgeneric find-oldest-construct (construct-1 construct-2) + (:documentation "Returns the construct which owns the oldes version info. + If a construct is not a versioned construct the oldest + association determines the construct's version info.")) -(defmethod find-most-recent-revision ((construct TopicMapConstructC)) - (when (find 0 (versions construct) :key #'end-revision) - construct)) -(defmethod delete-construct :before ((construct TopicMapConstructC)) - (dolist (versionInfo (versions construct)) - (delete-construct versionInfo))) +(defgeneric merge-constructs (construct-1 construct-2 &key revision) + (:documentation "Merges two constructs of the same type if they are + mergable. The latest construct will be marked as deleted + The older one gets all characteristics of the marked as + deleted one. All referenced constructs are also updated + with the changeds that are caused by this operation.")) -(defgeneric check-for-duplicate-identifiers (top) +(defgeneric parent-delete-parent (construct parent-construct &key revision) + (:documentation "Sets the assoication-object between the passed + constructs as marded-as-deleted.")) + + +(defgeneric delete-parent (construct parent-construct &key revision) + (:documentation "See private-delete-parent but adds the parent to + the given version.")) + + +(defgeneric add-parent (construct parent-construct &key revision) + (:documentation "Adds the parent-construct (TopicC or NameC) in form of + a corresponding association to the given object.")) + + +(defgeneric find-item-by-revision (construct revision + &optional parent-construct) + (:documentation "Returns the given object if it exists in the passed + version otherwise nil. + Constructs that exist to be owned by parent-constructs + must provide their parent-construct to get the corresponding + revision of the relationship between the construct itself and + its parent-construct.")) + + +(defgeneric check-for-duplicate-identifiers (construct &key revision) (:documentation "Check for possibly duplicate identifiers and signal an duplicate-identifier-error is such duplicates are found")) -(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)) - (declare (ignore construct)) - ;do nothing - ) -(defgeneric filter-slot-value-by-revision (construct slot-name &key start-revision) - (:documentation "filter slot values by a given revision that is - either provided directly through the keyword argument start-revision - or through a bound variable named '*TM-REVISION*'")) +(defgeneric get-all-identifiers-of-construct (construct &key revision) + (:documentation "Get all identifiers that a given construct has")) -(defmethod filter-slot-value-by-revision ((construct TopicMapConstructC) (slot-name symbol) &key (start-revision 0 start-revision-provided-p)) - (let - ((revision ;avoids warnings about undefined variables - (cond - (start-revision-provided-p - start-revision) - ((boundp '*TM-REVISION*) - (symbol-value '*TM-REVISION*)) - (t 0))) - (properties (slot-value construct slot-name))) - ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) - (cond - ((not properties) - nil) ;if we don't have any properties, we don't have to worry - ;about revisions - ((= 0 revision) - (remove - nil - (map 'list #'find-most-recent-revision - properties))) - (t - (remove nil - (map 'list - (lambda (constr) - (find-item-by-revision constr revision)) - properties)))))) - -(defgeneric make-construct (classsymbol &key start-revision &allow-other-keys) - (:documentation "create a new topic map construct if necessary or -retrieve an equivalent one if available and update the revision -history accordingly. Return the object in question. Methods use -specific keyword arguments for their purpose")) - -(defmethod make-construct ((classsymbol symbol) &rest args - &key start-revision) - (let* - ((cleaned-args (remove-nil-values args)) - (new-construct (apply #'make-instance classsymbol cleaned-args)) - (existing-construct (first (find-all-equivalent new-construct)))) - (if existing-construct - (progn - ;change over new item identifiers to the old construct - ;the version-history is also changed if the construct was - ;marked-as-deleted before - (when (or (copy-item-identifiers new-construct existing-construct) - (not (find-most-recent-revision existing-construct))) - (add-to-version-history existing-construct - :start-revision start-revision)) - - (delete-construct new-construct) - existing-construct) - (progn - (add-to-version-history new-construct :start-revision start-revision) - (check-for-duplicate-identifiers new-construct) - new-construct)))) - -(defmethod get-most-recent-version-info ((construct TopicMapConstructC)) + +(defgeneric get-all-characteristics (parent-construct characteristic-symbol) + (:documentation "Returns all characterisitcs of the passed type the parent + construct was ever associated with.")) + + +(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). Parent-equality is not + checked in this methods, so the user has to pass children of + the same parent.")) + + +(defgeneric equivalent-constructs (construct-1 construct-2 &key revision) + (:documentation "Returns t if the passed constructs are equivalent to each + other (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) + (: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 construct 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)) + (delete-1-n-association version-info 'versioned-construct)) + + +;;; VersionedConstructC +(defgeneric exist-in-version-history-p (versioned-construct) + (:documentation "Returns t if the passed construct does not exist in any + revision, i.e. the construct has no version-infos or exactly + one whose start-revision is equal to its end-revision.") + (:method ((versioned-construct VersionedConstructC)) + (or (not (versions versioned-construct)) + (and (= (length (versions versioned-construct)) 1) + (= (start-revision (first (versions versioned-construct))) + (end-revision (first (versions versioned-construct)))))))) + + +(defmethod find-oldest-construct ((construct-1 VersionedConstructC) + (construct-2 VersionedConstructC)) + (let ((vi-1 (find-version-info (list construct-1))) + (vi-2 (find-version-info (list construct-2)))) + (cond ((not (or vi-1 vi-2)) + construct-1) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) + + +(defgeneric VersionedConstructC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to VersionedConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'VersionedconstructC) + (TopicC-p class-symbol) + (TopicMapC-p class-symbol) + (AssociationC-p class-symbol)))) + + +(defmethod delete-construct :before ((construct VersionedConstructC)) + (dolist (version-info (versions construct)) + (delete-construct version-info))) + + +(defmethod find-item-by-revision ((construct VersionedConstructC) + (revision integer) &optional parent-construct) + (declare (ignorable parent-construct)) + (cond ((= revision 0) + (find-most-recent-revision construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions construct)) + construct)))) + + +(defmethod get-most-recent-version-info ((construct VersionedConstructC)) (let ((result (find 0 (versions construct) :key #'end-revision))) (if result result ;current version-info -> end-revision = 0 @@ -520,1159 +1082,3313 @@ (when sorted-list (first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer -(defgeneric equivalent-constructs (construct1 construct2) - (:documentation "checks if two topic map constructs are equal according to the TMDM equality rules")) -(defgeneric strictly-equivalent-constructs (construct1 construct2) - (:documentation "checks if two topic map constructs are not identical but equal according to the TMDM equality rules") - (:method ((construct1 TopicMapConstructC) (construct2 TopicMapConstructC)) - (and (equivalent-constructs construct1 construct2) - (not (eq construct1 construct2))))) +(defgeneric find-most-recent-revision (construct) + (:documentation "Returns the latest version-info-object of the passed + construct.") + (:method ((construct VersionedConstructC)) + (when (find 0 (versions construct) :key #'end-revision) + construct))) -(defgeneric internal-id (construct) - (:documentation "returns the internal id that uniquely identifies a - construct (currently simply its OID)")) -(defmethod internal-id ((construct TopicMapConstructC)) - (slot-value construct (find-symbol "OID" 'elephant))) +(defun add-version-info(construct start-revision) + "Adds 'construct' to the given version. + If the construct is a VersionedConstructC add-to-version-history + is called directly. Otherwise there is called a corresponding + add-<whatever> method that adds recursively 'construct' to its + parent and so on." + (declare (type (or TopicMapConstructC VersionedConstructC) construct) + (integer start-revision)) + (cond ((typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision start-revision)) + ((typep construct 'VariantC) + (let ((name (parent construct :revision start-revision))) + (when name + (add-variant name construct :revision start-revision) + (let ((top (parent name :revision start-revision))) + (when top + (add-name top name :revision start-revision)))))) + ((typep construct 'CharacteristicC) + (let ((top (parent construct :revision start-revision))) + (when top + (add-characteristic top construct :revision start-revision)))) + ((typep construct 'RoleC) + (let ((assoc (parent construct :revision start-revision))) + (when assoc + (add-role assoc construct :revision start-revision)))))) -;;;;;;;;;;;;;; -;; -;; TopicIdentificationC - -(elephant:defpclass TopicIdentificationC (PointerC) - ((xtm-id - :accessor xtm-id - :type string - :initarg :xtm-id - :index t - :documentation "ID of the TM this identification came from")) - (:documentation "Identify topic items through generalized - topicids. A topic may have many original topicids, the class - representing one of them") ) - -(defmethod find-all-equivalent ((construct TopicIdentificationC)) - (delete (xtm-id construct) (call-next-method) :key #'xtm-id :test #'string=)) - -(defun init-topic-identification (top id xtm-id &key (revision *TM-REVISION*)) - "create a TopicIdentification object (if necessary) and initialize it with the - combination of the current topicid and the ID of the current XTM id" - ;(declare (TopicC top)) - (declare (string id)) - - (flet ;prevent unnecessary copies of TopicIdentificationC objects - ((has-topic-identifier (top uri xtm-id) - (remove-if-not - (lambda (ident) - (and (string= (uri ident) uri) - (string= (xtm-id ident) xtm-id))) - (topic-identifiers top)))) - (unless (has-topic-identifier top id xtm-id) - (let - ((ti - (make-instance - 'TopicIdentificationC - :uri id - :xtm-id xtm-id - :identified-construct top - :start-revision revision))) - ;(add-to-version-history ti :start-revision revision) - ti)))) - -(defun xtm-id-p (xtm-id) - "checks if a xtm-id has been used before" - (elephant:get-instance-by-value 'TopicIdentificationC - 'xtm-id xtm-id)) - - -;;;;;;;;;;;;;; -;; -;; PSI - -(elephant:defpclass PersistentIdC (IdentifierC) - ((identified-construct :accessor identified-construct - :initarg :identified-construct - :associate TopicC)) - (:index t) - (:documentation "Represents a PSI")) +(defgeneric add-to-version-history (construct &key start-revision end-revision) + (:documentation "Adds version history to a versioned construct") + (:method ((construct VersionedConstructC) + &key (start-revision (error (make-missing-argument-condition "From add-to-version-history(): start revision must be present" 'start-revision 'add-to-version-history))) + (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) end-revision) + current-version-info) + ((and current-version-info + (= (end-revision current-version-info) 0)) + (setf (end-revision current-version-info) start-revision) + (let ((vi (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision))) + (elephant:add-association vi 'versioned-construct construct))) + (t + (let ((vi (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision))) + (elephant:add-association vi 'versioned-construct construct))))))))) + + + +(defmethod marked-as-deleted-p ((construct VersionedConstructC)) + (unless (find-if #'(lambda(vi) + (= (end-revision vi) 0)) + (versions construct)) + t)) + + +(defmethod mark-as-deleted ((construct VersionedConstructC) + &key source-locator revision) + (declare (ignorable source-locator)) + (let + ((last-version ;the last active version + (find 0 (versions construct) :key #'end-revision))) + (if (and last-version + (= (start-revision last-version) revision)) + (progn + (delete-construct last-version) + (let ((sorted-versions + (sort (versions construct) #'> :key #'end-revision))) + (when sorted-versions + (setf (end-revision (first sorted-versions)) revision)))) + (when last-version + (setf (end-revision last-version) revision))))) + + +;;; TopicMapconstructC +(defgeneric strictly-equivalent-constructs (construct-1 construct-2 + &key revision) + (:documentation "Checks if two topic map constructs are not identical but + equal according to the TMDM equality rules.") + (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (equivalent-constructs construct-1 construct-2 :revision revision) + (not (eql construct-1 construct-2))))) + + +(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC) + &key revision) + (declare (ignorable revision construct)) + ;do nothing + ) -;;;;;;;;;;;;;; -;; -;; ReifiableConstructC - -(elephant:defpclass ReifiableConstructC (TopicMapConstructC) - ((item-identifiers - :associate (ItemIdentifierC identified-construct) - :inherit t - :documentation "Slot that realizes a 1 to N - relation between reifiable constructs and their - identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs") - (reifier - :associate TopicC - :inherit t - :documentation "Represents a reifier association to a topic, i.e. - it stands for a 1:1 association between this class and TopicC")) - (:documentation "Reifiable constructs as per TMDM")) +(defmethod get-all-characteristics ((parent-construct TopicC) + (characteristic-symbol symbol)) + (cond ((OccurrenceC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'occurrences))) + ((NameC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'names))))) + + +(defgeneric TopicMapConstructC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to TopicMapConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'TopicMapConstructC) + (ReifiableConstructC-p class-symbol) + (PointerC-p class-symbol)))) + + +;;; PointerC +(defmethod versions ((construct PointerC)) + "Returns all versions that are indirectly through all PointerAssocitiations + bound to the passed pointer object." + (loop for p-assoc in (slot-p construct 'identified-construct) + append (versions p-assoc))) + + +(defmethod mark-as-deleted ((construct PointerC) &key source-locator revision) + "Marks the last active relation between a pointer and its parent construct + as deleted." + (declare (ignorable source-locator)) + (let ((owner (identified-construct construct :revision 0))) + (when owner + (cond ((typep construct 'PersistentIdC) + (private-delete-psi owner construct :revision revision)) + ((typep construct 'SubjectLocatorC) + (private-delete-locator owner construct :revision revision)) + ((typep construct 'ItemIdentifierC) + (private-delete-item-identifier owner construct :revision revision)) + ((typep construct 'TopicIdentificationC) + (private-delete-topic-identifier owner construct :revision revision)))))) + + +(defmethod marked-as-deleted-p ((construct PointerC)) + (unless (identified-construct construct :revision 0) + t)) + + +(defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC)) + (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct))) + (vi-2 (find-version-info (slot-p construct-2 'identified-construct)))) + (cond ((not (or vi-1 vi-2)) + construct-1) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) + + +(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC) + &key (revision nil)) + (declare (ignorable revision)) + (string= (uri construct-1) (uri construct-2))) + + +(defgeneric PointerC-p (class-symbol) + (:documentation "Returns t if the passed symbol corresponds to the class + PointerC or one of its subclasses.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'PointerC) + (IdentifierC-p class-symbol) + (TopicIdentificationC-p class-symbol) + (PersistentIdC-p class-symbol) + (ItemIdentifierC-p class-symbol) + (SubjectLocatorC-p class-symbol)))) + + +(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)) + + +(defmethod find-item-by-revision ((construct PointerC) + (revision integer) &optional parent-construct) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'identified-construct))))) + (when assocs + (first assocs))))) + (when parent-assoc + (cond ((= revision 0) + (find-most-recent-revision parent-assoc)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) + nil)) -(defgeneric reifier (construct &key revision) - (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) - (when (slot-boundp construct 'reifier) - (slot-value construct 'reifier)))) +(defmethod delete-construct :before ((construct PointerC)) + (dolist (p-assoc (slot-p construct 'identified-construct)) + (delete-construct p-assoc))) -(defgeneric (setf reifier) (topic TopicC) - (:method (topic (construct ReifiableConstructC)) - (setf (slot-value construct 'reifier) topic))) -; (setf (reified topic) construct))) -(defgeneric item-identifiers (construct &key revision) - (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) +(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.") + (:method ((construct PointerC) &key (revision *TM-REVISION*)) + (let ((assocs + (map 'list #'parent-construct + (filter-slot-value-by-revision construct 'identified-construct + :start-revision revision)))) + (when assocs ;result must be nil or a list with one item + (first assocs))))) + + +;;; TopicIdentificationC +(defmethod equivalent-constructs ((construct-1 TopicIdentificationC) + (construct-2 TopicIdentificationC) + &key (revision nil)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (xtm-id construct-1) (xtm-id construct-2)))) + -(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil)) - "adds associations to these ids after the instance was initialized." - (declare (list item-identifiers)) - (call-next-method) - (dolist (id item-identifiers) - (declare (ItemIdentifierC id)) - (setf (identified-construct id) instance)) - (when reifier - (add-reifier instance reifier)) - ;(setf (reifier instance) reifier)) - instance) -(defmethod delete-construct :before ((construct ReifiableConstructC)) - (dolist (id (item-identifiers construct)) - (delete-construct id)) - (when (reifier construct) - (let ((reifier-topic (reifier construct))) - (remove-reifier construct) - (delete-construct reifier-topic)))) - -(defgeneric item-identifiers-p (constr) - (:documentation "Test for the existence of item identifiers") - (:method ((construct ReifiableConstructC)) (slot-predicate construct 'item-identifiers))) - -(defgeneric topicid (construct &optional xtm-id) - (:documentation "Return the ID of a construct")) - -(defmethod revision ((constr ReifiableConstructC)) - (start-revision constr)) +(defgeneric TopicIdentificationC-p (class-symbol) + (:documentation "Returns t if the passed class symbol is equal + to TopicIdentificationC.") + (:method ((class-symbol symbol)) + (eql class-symbol '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 + :uri uri))) + (and equivalent-pointer + (string= (xtm-id construct) xtm-id)))) + + +;;; IdentifierC +(defgeneric IdentifierC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to IdentifierC + or one of its sybtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'IdentifierC) + (PersistentIdC-p class-symbol) + (SubjectLocatorC-p class-symbol) + (ItemIdentifierC-p class-symbol)))) + + +;;; PersistentIdC +(defgeneric PersistentIdC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to PersistentIdC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'PersistentIdC))) + + +;;; ItemIdentifierC +(defgeneric ItemIdentifierC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to ItemIdentifierC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'ItemIdentifierC))) + +;;; SubjectLocatorC +(defgeneric SubjectLocatorC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to SubjectLocatorC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'SubjectLocatorC))) + + +;;; 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 'characteristic)) + + +;;; 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)) + + +;;; 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 mark-as-deleted :around ((top TopicC) + &key (source-locator nil sl-provided-p) + revision) + "Mark a topic as deleted if it comes from the source indicated by + source-locator" + ;;Part 1b, 1.4.3.3.1: + ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F + ;; * Let SI be the value of TopicSI element in ATOM entry E + ;; * feed F contains E) + ;; * entry E references topic fragment TF + ;; * Let LTM be the local topic map + ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI + ;; * For all names, occurrences and associations in which T plays a role, TMC + ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC + ;; * Merge in the fragment TF using SP as the base all generated source locators. + (when (or (and (not source-locator) sl-provided-p) + (and sl-provided-p + (some (lambda (psi) (string-starts-with (uri psi) source-locator)) + (psis top :revision 0)))) + (unless sl-provided-p + (mapc (lambda(psi)(mark-as-deleted psi :revision revision + :source-locator source-locator)) + (psis top :revision 0))) + (mapc (lambda(sl)(mark-as-deleted sl :revision revision + :source-locator source-locator)) + (locators top :revision 0)) + (mapc (lambda (name) (mark-as-deleted name :revision revision + :source-locator source-locator)) + (names top :revision 0)) + (mapc (lambda (occ) (mark-as-deleted occ :revision revision + :source-locator source-locator)) + (occurrences top :revision 0)) + (mapc (lambda (ass) (mark-as-deleted ass :revision revision + :source-locator source-locator)) + (find-all-associations top :revision 0)) + (call-next-method))) -(defgeneric (setf revision) (revision construct) - (:documentation "The corresponding setter method")) -(defmethod (setf revision) ((revision integer) (constr ReifiableConstructC)) - (setf (start-revision constr) revision)) +(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((ids-1 (union (union (item-identifiers construct-1 :revision revision) + (locators construct-1 :revision revision)) + (psis construct-1 :revision revision))) + (ids-2 (union (union (item-identifiers construct-2 :revision revision) + (locators construct-2 :revision revision)) + (psis construct-2 :revision revision)))) + (when (intersection ids-1 ids-2) + t))) + + +(defgeneric TopicC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to TopicC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicC))) + + +(defmethod equivalent-construct ((construct TopicC) + &key (start-revision *TM-REVISION*) (psis nil) + (locators nil) (item-identifiers nil) + (topic-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 + topic-identifiers)) + (when + (intersection + (union (union (psis construct :revision start-revision) + (locators construct :revision start-revision)) + (union (item-identifiers construct :revision start-revision) + (topic-identifiers construct :revision start-revision))) + (union (union psis locators) (union item-identifiers topic-identifiers))) + t)) -(defgeneric get-all-identifiers-of-construct (construct) - (:documentation "Get all identifiers that a given construct has")) -(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC)) - (item-identifiers construct)) +(defmethod delete-construct :before ((construct TopicC)) + (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))) + (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)) + (when (slot-p construct 'in-topicmaps) + t)) + + +(defgeneric topic-id (construct &optional revision xtm-id) + (:documentation "Returns the primary id of this item + (= essentially the OID). If xtm-id is explicitly given, + returns one of the topic-ids in that TM + (which must then exist).") + (:method ((construct TopicC) &optional (revision *TM-REVISION*) (xtm-id nil)) + (declare (type (or string null) xtm-id) + (type (or integer null) revision)) + (if xtm-id + (let ((possible-identifiers + (remove-if-not + #'(lambda(top-id) + (string= (xtm-id top-id) xtm-id)) + (topic-identifiers construct :revision revision)))) + (unless possible-identifiers + (error (make-object-not-found-condition (format nil "Could not find an object ~a in xtm-id ~a" construct xtm-id)))) + (uri (first possible-identifiers))) + (concatenate 'string "t" (write-to-string (internal-id construct)))))) + + +(defgeneric topic-identifiers (construct &key revision) + (:documentation "Returns the TopicIdentificationC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'topic-identifiers :start-revision revision))) + (map 'list #'identifier assocs)))) + + +(defgeneric add-topic-identifier (construct topic-identifier &key revision) + (:documentation "Adds the passed topic-identifier to the passed topic. + If the topic-identifier is already related with the passed + topic a new revision is added. + If the passed identifer already identifies another object + the identified-constructs are merged.") + (:method ((construct TopicC) (topic-identifier TopicIdentificationC) + &key (revision *TM-REVISION*)) + (let ((all-ids + (map 'list #'identifier (slot-p construct 'topic-identifiers))) + (construct-to-be-merged + (let ((id-owner (identified-construct topic-identifier + :revision revision))) + (when (not (eql id-owner construct)) + id-owner)))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find topic-identifier all-ids) + (let ((ti-assoc (loop for ti-assoc in (slot-p construct + 'topic-identifiers) + when (eql (identifier ti-assoc) + topic-identifier) + return ti-assoc))) + (add-to-version-history ti-assoc :start-revision revision))) + (t + (make-construct 'TopicIdAssociationC + :parent-construct construct + :identifier topic-identifier + :start-revision revision))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) + + +(defgeneric private-delete-topic-identifier + (construct topic-identifier &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (topic-identifier TopicIdentificationC) + &key (revision (error (make-missing-argument-condition "From private-delete-topic-identifier(): revision must be set" 'revision 'private-delete-topic-identifier)))) + (let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers) + when (eql (identifier ti-assoc) topic-identifier) + return ti-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-topic-identifier + (construct topic-identifier &key revision) + (:documentation "See private-delete-topic-identifier but adds the parent + construct to the given version") + (:method ((construct TopicC) (topic-identifier TopicIdentificationC) + &key (revision (error (make-missing-argument-condition "From delete-topic-identifier(): revision must be set" 'revision 'delete-topic-identifier)))) + (when (private-delete-topic-identifier construct topic-identifier + :revision revision) + (add-to-version-history construct :start-revision revision) + construct))) -(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)) - (dolist (id (get-all-identifiers-of-construct construct)) - (when (> (length - (union - (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id)) - (union - (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id)) - (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id))))) - 1) - (error - (make-condition 'duplicate-identifier-error - :message (format nil "Duplicate Identifier ~a has been found" (uri id)) - :uri (uri id)))))) - -(defmethod copy-item-identifiers ((from-construct ReifiableConstructC) - (to-construct ReifiableConstructC)) - "Internal method to copy over item idenfiers from a construct to -another on. Returns the set of new identifiers" - (mapc - (lambda (identifier) - (setf (identified-construct identifier) - to-construct)) - (set-difference (item-identifiers from-construct) - (item-identifiers to-construct) - :key #'uri :test #'string=))) - -;;;;;;;;;;;;;; -;; -;; ScopableC - -(elephant:defpclass ScopableC () - ((themes :accessor themes - :associate (TopicC used-as-theme) - :inherit t - :many-to-many t - :documentation "list of this scope's themes; pseudo-initarg is :themes"))) -(defmethod initialize-instance :around ((instance ScopableC) &key (themes nil)) - (declare (list themes)) - (call-next-method) - (dolist (theme themes) - (elephant:add-association instance 'themes theme)) - instance) +(defgeneric psis (construct &key revision) + (:documentation "Returns the PersistentIdC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'psis :start-revision revision))) + (map 'list #'identifier assocs)))) + + +(defgeneric add-psi (construct psi &key revision) + (:documentation "Adds the passed psi to the passed topic. + If the psi is already related with the passed + topic a new revision is added. + If the passed identifer already identifies another object + the identified-constructs are merged.") + (:method ((construct TopicC) (psi PersistentIdC) + &key (revision *TM-REVISION*)) + (let ((all-ids + (map 'list #'identifier (slot-p construct 'psis))) + (construct-to-be-merged + (let ((id-owner (identified-construct psi :revision revision))) + (when (not (eql id-owner construct)) + id-owner)))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find psi all-ids) + (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) + when (eql (identifier psi-assoc) psi) + return psi-assoc))) + (add-to-version-history psi-assoc :start-revision revision))) + (t + (make-construct 'PersistentIdAssociationC + :parent-construct construct + :identifier psi + :start-revision revision))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) + + +(defgeneric private-delete-psi (construct psi &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (psi PersistentIdC) + &key (revision (error (make-missing-argument-condition "From private-delete-psi(): revision must be set" 'revision 'private-delete-psi)))) + (let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis) + when (eql (identifier psi-assoc) psi) + return psi-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-psi (construct psi &key revision) + (:documentation "See private-delete-psis but adds the parent to the given + version.") + (:method ((construct TopicC) (psi PersistentIdC) + &key (revision (error (make-missing-argument-condition "From delete-psi(): revision must be set" 'revision 'delete-psi)))) + (when (private-delete-psi construct psi :revision revision) + (add-to-version-history construct :start-revision revision) + construct))) -(defmethod delete-construct :before ((construct ScopableC)) - (dolist (theme (themes construct)) - (elephant:remove-association construct 'themes theme))) +(defgeneric locators (construct &key revision) + (:documentation "Returns the SubjectLocatorC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'locators :start-revision revision))) + (map 'list #'identifier assocs)))) + + +(defgeneric add-locator (construct locator &key revision) + (:documentation "Adds the passed locator to the passed topic. + If the locator is already related with the passed + topic a new revision is added. + If the passed identifer already identifies another object + the identified-constructs are merged.") + (:method ((construct TopicC) (locator SubjectLocatorC) + &key (revision *TM-REVISION*)) + (let ((all-ids + (map 'list #'identifier (slot-p construct 'locators))) + (construct-to-be-merged + (let ((id-owner (identified-construct locator :revision revision))) + (when (not (eql id-owner construct)) + id-owner)))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find locator all-ids) + (let ((loc-assoc + (loop for loc-assoc in (slot-p construct 'locators) + when (eql (identifier loc-assoc) locator) + return loc-assoc))) + (add-to-version-history loc-assoc :start-revision revision))) + (t + (make-construct 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator + :start-revision revision))) + (add-to-version-history merged-construct :start-revision revision) + merged-construct)))) + + +(defgeneric private-delete-locator (construct locator &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (locator SubjectLocatorC) + &key (revision (error (make-missing-argument-condition "From private-delete-locator(): revision must be set" 'revision 'private-delete-locator)))) + (let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators) + when (eql (identifier loc-assoc) locator) + return loc-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-locator (construct locator &key revision) + (:documentation "See private-delete-locator but add the parent construct + to the given version.") + (:method ((construct TopicC) (locator SubjectLocatorC) + &key (revision (error (make-missing-argument-condition "From delete-locator(): revision must be set" 'revision 'delete-locator)))) + (when (private-delete-locator construct locator :revision revision) + (add-to-version-history construct :start-revision revision) + construct))) -;;;;;;;;;;;;;; -;; -;; TypableC - -(elephant:defpclass TypableC () - ((instance-of :accessor instance-of - :initarg :instance-of - :associate TopicC - :inherit t - :documentation "topic that this construct is an instance of"))) -(defmethod delete-construct :before ((construct TypableC)) - (when (instance-of-p construct) - (elephant:remove-association construct 'instance-of (instance-of construct)))) +(defmethod get-all-identifiers-of-construct ((construct TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (append (psis construct :revision revision) + (locators construct :revision revision) + (item-identifiers construct :revision revision))) + + +(defgeneric names (construct &key revision) + (:documentation "Returns the NameC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'names :start-revision revision))) + (map 'list #'characteristic assocs)))) + + +(defgeneric add-name (construct name &key revision) + (:documentation "Adds the passed name to the passed topic. + If the name is already related with the passed + topic a new revision is added. + If the passed name already owns another object + an error is thrown.") + (:method ((construct TopicC) (name NameC) + &key (revision *TM-REVISION*)) + (when (and (parent name :revision revision) + (not (eql (parent name :revision revision) construct))) + (error (make-tm-reference-condition (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" + name construct (parent name :revision revision)) + name (parent name :revision revision) construct))) + (if (merge-if-equivalent name construct :revision revision) + construct + (let ((all-names + (map 'list #'characteristic (slot-p construct 'names)))) + (if (find name all-names) + (let ((name-assoc + (loop for name-assoc in (slot-p construct 'names) + when (eql (parent-construct name-assoc) + construct) + return name-assoc))) + (add-to-version-history name-assoc :start-revision revision)) + (make-construct 'NameAssociationC + :parent-construct construct + :characteristic name + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) + + +(defgeneric private-delete-name (construct name &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (name NameC) + &key (revision (error (make-missing-argument-condition "From private-delete-name(): revision must be set" 'revision 'private-delete-name)))) + (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) + when (eql (characteristic name-assoc) name) + return name-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-name (construct name &key revision) + (:documentation "See private-delete-name but adds the parent to + the given version.") + (:method ((construct TopicC) (name NameC) + &key (revision (error (make-missing-argument-condition "From delete-name(): revision must be set" 'revision 'delete-name)))) + (when (private-delete-name construct name :revision revision) + (add-to-version-history construct :start-revision revision) + construct))) -(defgeneric instance-of-p (construct) - (:documentation "is the instance-of slot bound and not nil") - (:method ((construct TypableC)) (slot-predicate construct 'instance-of))) +(defgeneric occurrences (construct &key revision) + (:documentation "Returns the OccurrenceC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'occurrences :start-revision revision))) + (map 'list #'characteristic assocs)))) + + +(defgeneric add-occurrence (construct occurrence &key revision) + (:documentation "Adds the passed occurrence to the passed topic. + If the occurrence is already related with the passed + topic a new revision is added. + If the passed occurrence already owns another object + an error is thrown.") + (:method ((construct TopicC) (occurrence OccurrenceC) + &key (revision *TM-REVISION*)) + (when (and (parent occurrence :revision revision) + (not (eql (parent occurrence :revision revision) construct))) + (error (make-tm-reference-condition (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" + occurrence construct (parent occurrence :revision revision)) + occurrence (parent occurrence :revision revision) construct))) + (if (merge-if-equivalent occurrence construct :revision revision) + construct + (let ((all-occurrences + (map 'list #'characteristic (slot-p construct 'occurrences)))) + (if (find occurrence all-occurrences) + (let ((occ-assoc + (loop for occ-assoc in (slot-p construct 'occurrences) + when (eql (parent-construct occ-assoc) construct) + return occ-assoc))) + (add-to-version-history occ-assoc :start-revision revision)) + (make-construct 'OccurrenceAssociationC + :parent-construct construct + :characteristic occurrence + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) + + +(defgeneric private-delete-occurrence (construct occurrence &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct TopicC) (occurrence OccurrenceC) + &key (revision (error (make-missing-argument-condition "From private-delete-occurrence(): revision must be set" 'revision 'private-delete-occurrence)))) + (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) + when (eql (characteristic occ-assoc) occurrence) + return occ-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-occurrence (construct occurrence &key revision) + (:documentation "See private-delete-occurrence but adds the parent + to the given version history.") + (:method ((construct TopicC) (occurrence OccurrenceC) + &key (revision (error (make-missing-argument-condition "From delete-occurrence(): revision must be set" 'revision 'delete-occurrence)))) + (when (private-delete-occurrence construct occurrence :revision revision) + (add-to-version-history construct :start-revision revision) + construct))) -;; (defmethod equivalent-constructs ((scope1 ScopeC) (scope2 ScopeC)) -;; "scopes are equal if their themes are equal" -;; (let -;; ((themes1 -;; (map 'list #'internal-id (themes scope1))) -;; (themes2 -;; (map 'list #'internal-id (themes scope2)))) -;; (not (set-exclusive-or themes1 themes2 :key #'internal-id)))) - -;;;;;;;;;;;;;; -;; -;; CharacteristicC - -(elephant:defpclass CharacteristicC (ReifiableConstructC ScopableC TypableC) - ((topic :accessor topic - :initarg :topic - :associate TopicC - :documentation "The topic that this characteristic belongs to") - (charvalue :accessor charvalue - :type string - :initarg :charvalue - :index t - :documentation "the value of the characteristic in the given scope")) - (:documentation "Scoped characteristic of a topic (meant to be used - as an abstract class)")) +(defmethod add-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (add-name construct characteristic :revision revision) + (add-occurrence construct characteristic :revision revision))) + + +(defmethod private-delete-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic)))) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (private-delete-name construct characteristic :revision revision) + (private-delete-occurrence construct characteristic + :revision revision))) + + +(defmethod delete-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic)))) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (delete-name construct characteristic :revision revision) + (delete-occurrence construct characteristic :revision revision))) + + +(defgeneric player-in-roles (construct &key revision) + (:documentation "Returns the RoleC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'player-in-roles :start-revision revision))) + (map 'list #'parent-construct assocs)))) + + +(defgeneric used-as-type (construct &key revision) + (:documentation "Returns the TypableC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'used-as-type :start-revision revision))) + (map 'list #'typable-construct assocs)))) + + +(defgeneric used-as-theme (construct &key revision) + (:documentation "Returns the ScopableC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'used-as-theme :start-revision revision))) + (map 'list #'scopable-construct assocs)))) + + +(defgeneric reified-construct (construct &key revision) + (:documentation "Returns the ReifiableConstructC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'reified-construct :start-revision revision))) + (when assocs + (reifiable-construct (first assocs)))))) + + +(defgeneric add-reified-construct (construct reified-construct &key revision) + (:documentation "Sets the passed construct as reified-consturct of the given + topic.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (add-reifier reified-construct construct :revision revision))) + + +(defgeneric private-delete-reified-construct + (construct reified-construct &key revision) + (:documentation "Unsets the passed construct as reified-construct of the + given topic.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision (error (make-missing-argument-condition "From private-delete-reified-construct(): revision must be set" 'revision 'private-delete-reified-construct)))) + (declare (integer revision)) + (private-delete-reifier reified-construct construct + :revision revision))) + + +(defgeneric delete-reified-construct (construct reified-construct &key revision) + (:documentation "See private-delete-reified-construct but adds the + reifier to the given version.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision (error (make-missing-argument-condition "From -delete-reified-construct(): revision must be set" 'revision '-delete-reified-construct)))) + (declare (integer revision)) + (delete-reifier reified-construct construct :revision revision))) + + +(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) + (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) + + +(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) + (revision *TM-REVISION*) (error-if-nil nil)) + "Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM + is chosen. If xtm-id is nil, choose the global TM with its internal ID, if + applicable in the correct revision. If revison is provided, then the code checks + if the topic already existed in this revision and returns nil otherwise. + If no item meeting the constraints was found, then the return value is either + NIL or an error is thrown, depending on error-if-nil." + (declare (string topic-id) (integer revision)) + (let ((result + (if xtm-id + (let ((possible-top-ids + (delete-if-not + #'(lambda(top-id) + (and (typep top-id 'd:TopicIdentificationC) + ;fixes a bug in elephant -> all PointerCs are returned + (string= (xtm-id top-id) xtm-id) + (string= (uri top-id) topic-id))) + ;fixes a bug in get-instances-by-value that does a + ;case-insensitive comparision + (elephant:get-instances-by-value + 'TopicIdentificationC + 'uri topic-id)))) + (when (and possible-top-ids + (identified-construct (first possible-top-ids) + :revision revision)) + (unless (= (length possible-top-ids) 1) + (error (make-duplicate-identifier-condition + (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" + possible-top-ids topic-id xtm-id) + topic-id))) + (identified-construct (first possible-top-ids) + :revision revision) + ;no revision need not to be checked, since the revision + ;is implicitely checked by the function identified-construct + )) + (when (and (> (length topic-id) 0) + (eql (elt topic-id 0) #\t) + (string-integer-p (subseq topic-id 1))) + (let ((top-from-oid + (elephant::controller-recreate-instance + elephant::*store-controller* + (parse-integer (subseq topic-id 1))))) + (when (find-item-by-revision top-from-oid revision) + top-from-oid)))))) + (if (and error-if-nil (not result)) + (error (make-object-not-found-condition (format nil "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision))) + result))) + + +(defun get-item-by-identifier (uri &key (revision *TM-REVISION*) + (identifier-type-symbol 'PersistentIdC) + (error-if-nil nil)) + "Returns the construct that is bound to the given identifier-uri." + (declare (string uri) (integer revision) (symbol identifier-type-symbol)) + (let ((result + (let ((possible-ids + (delete-if-not + #'(lambda(id) + (and (typep id identifier-type-symbol) + (string= (uri id) uri))) + (get-instances-by-value identifier-type-symbol 'uri uri)))) + (when (and possible-ids + (identified-construct (first possible-ids) + :revision revision)) + (unless (= (length possible-ids) 1) + (error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri))) + (identified-construct (first possible-ids) + :revision revision))))) + ;no revision need to be checked, since the revision + ;is implicitely checked by the function identified-construct + (if (and result + (let ((parent-elem + (when (or (typep result 'CharacteristicC) + (typep result 'RoleC)) + (parent result :revision revision)))) + (find-item-by-revision result revision parent-elem))) + result + (when error-if-nil + (error (make-object-not-found-condition "No such item is bound to the given identifier uri.")))))) + + +(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*) + (error-if-nil nil)) + "Returns a ReifiableConstructC that is bound to the identifier-uri." + (get-item-by-identifier uri :revision revision + :identifier-type-symbol 'ItemIdentifierC + :error-if-nil error-if-nil)) + + +(defun get-item-by-psi (uri &key (revision *TM-REVISION*) (error-if-nil nil)) + "Returns a TopicC that is bound to the identifier-uri." + (get-item-by-identifier uri :revision revision + :identifier-type-symbol 'PersistentIdC + :error-if-nil error-if-nil)) + + +(defun get-item-by-locator (uri &key (revision *TM-REVISION*) (error-if-nil nil)) + "Returns a TopicC that is bound to the identifier-uri." + (get-item-by-identifier uri :revision revision + :identifier-type-symbol 'SubjectLocatorC + :error-if-nil error-if-nil)) + + +(defgeneric list-instanceOf (topic &key tm revision) + (:documentation "Generates a list of all topics that this topic is an + instance of, optionally filtered by a topic map") + (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) + (declare (type (or null TopicMapC) tm) + (integer revision)) + (remove-if + #'null + (map 'list + #'(lambda(x) + (when (loop for psi in (psis (instance-of x :revision revision) + :revision revision) + when (string= (uri psi) constants:*instance-psi*) + return t) + (loop for role in (roles (parent x :revision revision) + :revision revision) + when (not (eq role x)) + return (player role :revision revision)))) + (if tm + (remove-if-not + (lambda (role) + (in-topicmap tm (parent role :revision revision) + :revision revision)) + (player-in-roles topic :revision revision)) + (player-in-roles topic :revision revision)))))) + + +(defgeneric list-super-types (topic &key tm revision) + (:documentation "Generate a list of all topics that this topic is an + subclass of, optionally filtered by a topic map") + (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) + (declare (type (or null TopicMapC) tm) + (integer revision)) + (remove-if + #'null + (map 'list + #'(lambda(x) + (when (loop for psi in (psis (instance-of x :revision revision) + :revision revision) + when (string= (uri psi) *subtype-psi*) + return t) + (loop for role in (roles (parent x :revision revision) + :revision revision) + when (not (eq role x)) + return (player role :revision revision)))) + (if tm + (remove-if-not + (lambda (role) + (in-topicmap tm (parent role :revision revision) + :revision revision)) + (player-in-roles topic :revision revision)) + (player-in-roles topic :revision revision)))))) + + +;;; CharacteristicC +(defmethod versions ((construct CharacteristicC)) + "Returns all versions that are indirectly through all + CharacteristicAssocitiations bound to the passed characteristic object." + (loop for p-assoc in (slot-p construct 'parent) + append (versions p-assoc))) + + +(defmethod mark-as-deleted ((construct CharacteristicC) &key source-locator revision) + "Marks the last active relation between a characteristic and its parent topic + as deleted." + (declare (ignorable source-locator)) + (let ((owner (parent construct :revision 0))) + (when owner + (private-delete-characteristic owner construct :revision revision)))) + + +(defmethod marked-as-deleted-p ((construct CharacteristicC)) + (unless (parent construct :revision 0) + t)) + + +(defmethod find-self-or-equal ((construct CharacteristicC) + (parent-construct TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or OccurrenceC NameC) construct)) + (let ((chars (if (typep construct 'OccurrenceC) + (occurrences parent-construct :revision revision) + (names parent-construct :revision revision)))) + (let ((self (find construct chars))) + (if self + self + (let ((equal-char + (remove-if #'null + (map 'list + #'(lambda(char) + (strictly-equivalent-constructs + char construct :revision revision)) + chars)))) + (when equal-char + (first equal-char))))))) + + +(defmethod delete-if-not-referenced ((construct CharacteristicC)) + (let ((references (slot-p construct 'parent))) + (when (or (not references) + (and (= (length references) 1) + (marked-as-deleted-p (first references)))) + (delete-construct construct)))) + + +(defmethod find-oldest-construct ((construct-1 CharacteristicC) + (construct-2 CharacteristicC)) + (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) + (vi-2 (find-version-info (slot-p construct-2 'parent)))) + (cond ((not (or vi-1 vi-2)) + construct-1) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) + + +(defmethod equivalent-constructs ((construct-1 CharacteristicC) + (construct-2 CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (string= (charvalue construct-1) (charvalue construct-2)) + (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (not (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision))))) + + +(defgeneric CharacteristicC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to CharacteristicC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'CharacteristicC) + (OccurrenceC-p class-symbol) + (NameC-p class-symbol) + (VariantC-p class-symbol)))) + + +(defmethod equivalent-construct ((construct CharacteristicC) + &key (start-revision *TM-REVISION*) + (charvalue "") (instance-of nil) (themes nil)) + "Equality rule: Characteristics are equal if charvalue, themes and + instance-of are equal." + (declare (string charvalue) (list themes) + (integer start-revision) + (type (or null TopicC) instance-of)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and (string= (charvalue construct) charvalue) + (equivalent-scopable-construct construct themes + :start-revision start-revision) + (equivalent-typable-construct construct instance-of + :start-revision start-revision))) + + +(defmethod find-item-by-revision ((construct CharacteristicC) + (revision integer) &optional parent-construct) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (when parent-assoc + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) + nil)) -(defgeneric CharacteristicC-p (object) - (:documentation "test if object is a of type CharacteristicC") - (:method ((object t)) nil) - (:method ((object CharacteristicC)) object)) (defmethod delete-construct :before ((construct CharacteristicC)) - (delete-1-n-association construct 'topic)) + (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) + (delete-construct characteristic-assoc-to-delete))) -(defun get-item-by-content (content &key (revision *TM-REVISION*)) - "Find characteristis by their (atomic) content" - (flet - ((get-existing-instances (classname) - (delete-if-not #'(lambda (constr) - (find-item-by-revision constr revision)) - (elephant:get-instances-by-value classname 'charvalue content)))) - (nconc (get-existing-instances 'OccurenceC) - (get-existing-instances 'NameC)))) +(defmethod owned-p ((construct CharacteristicC)) + (when (slot-p construct 'parent) + t)) +(defmethod parent ((construct CharacteristicC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'parent + :start-revision revision))) + (when valid-associations + (parent-construct (first valid-associations))))) -;;;;;;;;;;;;;; -;; -;; VariantC -(elephant:defpclass VariantC (CharacteristicC) - ((datatype :accessor datatype - :initarg :datatype - :initform nil - :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)") - (name :accessor name - :initarg :name - :associate NameC - :documentation "references the NameC instance which is the owner of this element"))) +(defmethod add-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((already-set-parent (parent construct :revision revision)) + (same-parent-assoc ;should contain an object that was marked as deleted + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct (parent-construct parent-assoc)) + return parent-assoc))) + (when (and already-set-parent + (not (eql already-set-parent parent-construct))) + (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent) + construct (parent construct :revision revision) parent-construct))) + (let ((merged-char + (merge-if-equivalent construct parent-construct :revision revision))) + (if merged-char + merged-char + (progn + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc + :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc + :start-revision revision)) + (t + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision)))) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct))))) + + +(defmethod private-delete-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent)))) + (let ((assoc-to-delete + (loop for parent-assoc in (slot-p construct 'parent) + when (eql (parent-construct parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct))) -(defgeneric VariantC-p (object) - (:documentation "test if object is a of type VariantC") - (:method ((object t)) nil) - (:method ((object VariantC)) object)) +(defmethod delete-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent)))) + (let ((parent (parent construct :revision revision))) + (when (private-delete-parent construct parent-construct :revision revision) + (when parent + (add-version-info parent revision)) + construct))) -(defmethod delete-construct :before ((construct VariantC)) - (delete-1-n-association construct 'name)) +;;; OccurrenceC +(defmethod equivalent-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (datatype construct-1) (datatype construct-2)))) + + +(defgeneric OccurrenceC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to OccurrenceC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'OccurrenceC))) + + +(defmethod equivalent-construct ((construct OccurrenceC) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (instance-of nil) + (datatype "")) + "Occurrences are equal if their charvalue, datatype, themes and + instance-of properties are equal." + (declare (type (or null TopicC) instance-of) (string datatype) + (ignorable start-revision charvalue themes instance-of)) + (let ((equivalent-characteristic (call-next-method))) + ;; item-identifiers and reifers are not checked because the equaity have to + ;; be variafied without them + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; VariantC +(defmethod find-self-or-equal ((construct VariantC) (parent-construct NameC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((vars (variants parent-construct :revision revision))) + (let ((self (find construct vars))) + (if self + self + (let ((equal-var + (remove-if #'null + (map 'list + #'(lambda(var) + (strictly-equivalent-constructs + var construct :revision revision)) + vars)))) + (when equal-var + (first equal-var))))))) + + +(defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (datatype construct-1) (datatype construct-2)))) + + +(defgeneric VariantC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to VariantC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'VariantC))) + + +(defmethod equivalent-construct ((construct VariantC) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (datatype "")) + "Variants are equal if their charvalue, datatype and themes + properties are equal." + (declare (string datatype) (ignorable start-revision charvalue themes)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (let ((equivalent-characteristic (call-next-method))) + (and equivalent-characteristic + (string= (datatype construct) datatype)))) + + +;;; NameC +(defmethod get-all-characteristics ((parent-construct NameC) + (characteristic-symbol symbol)) + (when (VariantC-p characteristic-symbol) + (map 'list #'characteristic (slot-p parent-construct 'variants)))) + + +(defgeneric NameC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to Name.") + (:method ((class-symbol symbol)) + (eql class-symbol 'NameC))) + + +(defgeneric complete-name (construct variants &key start-revision) + (:documentation "Adds all given variants to the passed construct.") + (:method ((construct NameC) (variants list) + &key (start-revision *TM-REVISION*)) + (dolist (variant variants) + (add-variant construct variant :revision start-revision)) + construct)) -(defmethod find-all-equivalent ((construct VariantC)) - (let ((parent (and (slot-boundp construct 'name) - (name construct)))) - (when parent - (delete-if-not #'(lambda(x)(strictly-equivalent-constructs construct x)) - (slot-value parent 'variants))))) +(defmethod equivalent-construct ((construct NameC) + &key (start-revision *TM-REVISION*) + (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)) + (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 *TM-REVISION*)) + (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 (make-tm-reference-condition (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" + variant construct (parent variant :revision revision)) + variant (parent variant :revision revision) construct))) + (if (merge-if-equivalent variant construct :revision revision) + construct + (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)) + (make-construct 'VariantAssociationC + :characteristic variant + :parent-construct construct + :start-revision revision)) + (when (parent construct :revision revision) + (add-name (parent construct :revision revision) construct + :revision revision)) + construct)))) + + +(defgeneric private-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 (make-missing-argument-condition "From private-delete-variant(): revision must be set" 'revision 'private-delete-variant)))) + (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)))) + + +(defgeneric delete-variant (construct variant &key revision) + (:documentation "See private-delete-variant but adds a the parent + and the parent's parent to the given version history.") + (:method ((construct NameC) (variant VariantC) + &key (revision (error (make-missing-argument-condition "From delete-variant(): revision must be set" 'revision 'delete-variant)))) + (when (private-delete-variant construct variant :revision revision) + (when (parent construct :revision revision) + (add-name (parent construct :revision revision) construct + :revision revision) + construct)))) -(defmethod equivalent-constructs ((variant1 VariantC) (variant2 VariantC)) - "variant items are (TMDM(5.5)-)equal if the values of their - [value], [datatype], [scope], and [parent] properties are equal" - (and (string= (charvalue variant1) (charvalue variant2)) - (or (and (not (slot-boundp variant1 'datatype)) (not (slot-boundp variant2 'datatype))) - (and (slot-boundp variant1 'datatype) (slot-boundp variant2 'datatype) - (string= (datatype variant1) (datatype variant2)))) - (not (set-exclusive-or (themes variant1) (themes variant2) :key #'internal-id)))) - +(defmethod add-characteristic ((construct NameC) (characteristic VariantC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (add-variant construct characteristic :revision revision)) - -;;;;;;;;;;;;;; -;; -;; NameC -(elephant:defpclass NameC (CharacteristicC) - ((variants ;:accessor variants - :associate (VariantC name))) - (:documentation "Scoped name of a topic")) +(defmethod private-delete-characteristic ((construct NameC) (characteristic VariantC) + &key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic)))) + (declare (integer revision)) + (private-delete-variant construct characteristic :revision revision)) -(defgeneric variants (name &key revision) - (:method ((name NameC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision name 'variants :start-revision revision))) +(defmethod delete-characteristic ((construct NameC) (characteristic VariantC) + &key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic)))) + (declare (integer revision)) + (delete-variant construct characteristic :revision revision)) -(defgeneric NameC-p (object) - (:documentation "test if object is a of type NameC") - (:method ((object t)) nil) - (:method ((object NameC)) object)) +;;; AssociationC +(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision) + "Marks an association and its roles as deleted" + (mapc (lambda (role) + (mark-as-deleted role :revision revision :source-locator source-locator)) + (roles ass :revision 0)) + (call-next-method)) -(defmethod find-all-equivalent ((construct NameC)) - (let - ((parent (and (slot-boundp construct 'topic) - (topic construct)))) - (when parent - (delete-if-not - #'(lambda (cand) (strictly-equivalent-constructs construct cand)) - (slot-value parent 'names))))) +(defmethod equivalent-constructs ((construct-1 AssociationC) + (construct-2 AssociationC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (not (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision))) + + (not (set-exclusive-or + (roles construct-1 :revision revision) + (roles construct-2 :revision revision) + :test #'(lambda(role-1 role-2) + (strictly-equivalent-constructs role-1 role-2 + :revision revision)))))) + + +(defgeneric AssociationC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to AssociationC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'AssociationC))) + + +(defmethod equivalent-construct ((construct AssociationC) + &key (start-revision *TM-REVISION*) + (roles nil) (instance-of nil) (themes nil)) + "Associations are equal if their themes, instance-of and roles + properties are equal. + To avoid ceation of duplicate roles the parameter roles is a list of plists + of the form: ((:player <TopicC> :instance-of <TopicC> + :item-identifiers <(ItemIdentifierC)> :reifier <TopicC>))." + (declare (integer start-revision) (list roles themes) + (type (or null TopicC) instance-of)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (let ((checked-roles nil)) + (loop for plist in roles + do (let ((found-role + (find-if #'(lambda(assoc-role) + (equivalent-construct + assoc-role :player (getf plist :player) + :start-revision (or (getf plist :start-revision) + start-revision) + :instance-of (getf plist :instance-of))) + (roles construct :revision start-revision)))) + (when found-role + (push found-role checked-roles)))) + (and + (not (set-exclusive-or (roles construct :revision start-revision) + checked-roles)) + (= (length checked-roles) (length roles)) + (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (equivalent-scopable-construct construct themes + :start-revision start-revision)))) -(defmethod delete-construct :before ((construct NameC)) - (dolist (variant (variants construct)) - (delete-construct variant))) +(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))) + (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)) + (when (slot-p construct 'in-topicmaps) + t)) + + +(defgeneric roles (construct &key revision) + (:documentation "Returns all topics that correspond with the given revision + as a scope for the given topic.") + (:method ((construct AssociationC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'roles + :start-revision revision))) + (map 'list #'role valid-associations)))) + + +(defgeneric add-role (construct role &key revision) + (:documentation "Adds the given role to the passed association-construct.") + (:method ((construct AssociationC) (role RoleC) + &key (revision *TM-REVISION*)) + (if (merge-if-equivalent role construct :revision revision) + construct + (let ((all-roles + (map 'list #'role (slot-p construct 'roles)))) + (if (find role all-roles) + (let ((role-assoc + (loop for role-assoc in (slot-p construct 'roles) + when (eql (role role-assoc) role) + return role-assoc))) + (add-to-version-history role-assoc :start-revision revision)) + (make-construct 'RoleAssociationC + :role role + :parent-construct construct + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) + + +(defgeneric private-delete-role (construct role &key revision) + (:documentation "Deletes the passed role by marking it's association as + deleted in the passed revision.") + (:method ((construct AssociationC) (role RoleC) + &key (revision (error (make-missing-argument-condition "From private-delete-role(): revision must be set" 'revision 'private-delete-role)))) + (let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles) + when (eql (role role-assoc) role) + return role-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-role (construct role &key revision) + (:documentation "See private-delete-role but adds the parent association + to the given version.") + (:method ((construct AssociationC) (role RoleC) + &key (revision (error (make-missing-argument-condition "From delete-role(): revision must be set" 'revision 'delete-role)))) + (when (private-delete-role construct role :revision revision) + (add-to-version-history construct :start-revision revision) + construct))) -(defmethod equivalent-constructs ((name1 NameC) (name2 NameC)) - "check for the equlity of two names by the TMDM's equality -rules (5.4)" - (and - (string= (charvalue name1) (charvalue name2)) - (or (and (instance-of-p name1) - (instance-of-p name2) - (= (internal-id (instance-of name1)) - (internal-id (instance-of name2)))) - (and (not (instance-of-p name1)) (not (instance-of-p name2)))) - (not (set-exclusive-or (themes name1) (themes name2) :key #'internal-id)))) - +(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*)) + (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) +;;; RoleC +(defmethod mark-as-deleted ((construct RoleC) &key source-locator revision) + "Marks the last active relation between a role and its parent association + as deleted." + (declare (ignorable source-locator)) + (let ((owner (parent construct :revision 0))) + (when owner + (private-delete-role owner construct :revision revision)))) + + +(defmethod marked-as-deleted-p ((construct RoleC)) + (unless (parent construct :revision 0) + t)) -;;;;;;;;;;;;;; -;; -;; OccurrenceC -(elephant:defpclass OccurrenceC (CharacteristicC) - ((datatype :accessor datatype - :initarg :datatype - :initform nil - :documentation "The XML Schema datatype of the occurrencevalue (optional, always IRI for resourceRef)"))) +(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((p-roles (roles parent-construct :revision revision))) + (let ((self (find construct p-roles))) + (if self + self + (let ((equal-role + (remove-if #'null + (map 'list + #'(lambda(role) + (strictly-equivalent-constructs + role construct :revision revision)) + p-roles)))) + (when equal-role + (first equal-role))))))) + + +(defmethod delete-if-not-referenced ((construct RoleC)) + (let ((references (slot-p construct 'parent))) + (when (or (not references) + (and (= (length references) 1) + (marked-as-deleted-p (first references)))) + (delete-construct construct)))) + + +(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC)) + (let ((vi-1 (find-version-info (slot-p construct-1 'parent))) + (vi-2 (find-version-info (slot-p construct-2 'parent)))) + (cond ((not (or vi-1 vi-2)) + construct-1) + ((not vi-1) + construct-2) + ((not vi-2) + construct-1) + ((<= (start-revision vi-1) (start-revision vi-2)) + construct-1) + (t + construct-2)))) -(defgeneric OccurrenceC-p (object) - (:documentation "test if object is a of type OccurrenceC") - (:method ((object t)) nil) - (:method ((object OccurrenceC)) object)) +(defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (eql (player construct-1 :revision revision) + (player construct-2 :revision revision)))) + + +(defgeneric RoleC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to RoleC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'RoleC))) + + +(defmethod equivalent-construct ((construct RoleC) + &key (start-revision *TM-REVISION*) + (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)) + ;; item-identifiers and reifers are not checked because the equality have to + ;; be variafied without them + (and (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (eql player (player construct :revision start-revision)))) + + +(defmethod find-item-by-revision ((construct RoleC) + (revision integer) &optional parent-construct) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (when parent-assoc + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) + nil)) -(defmethod find-all-equivalent ((construct OccurrenceC)) - (let - ((parent (and (slot-boundp construct 'topic) - (topic construct)))) - (when parent - (delete-if-not #'(lambda (cand) (strictly-equivalent-constructs construct cand)) - (slot-value parent 'occurrences))))) - -(defmethod equivalent-constructs ((occ1 OccurrenceC) (occ2 OccurrenceC)) - "Occurrence items are equal if the values of their [value], [datatype], [scope], [type], and [parent] properties are equal (TMDM 5.6)" - (and - (string= (charvalue occ1) (charvalue occ2)) - (not (set-exclusive-or (themes occ1) (themes occ2) :key #'internal-id)) - (= (internal-id (topic occ1)) (internal-id (topic occ2))) - (or - (and (instance-of-p occ1) (instance-of-p occ2) - (= - (internal-id (instance-of occ1)) - (internal-id (instance-of occ2)))) - (and (not (instance-of-p occ1)) (not (instance-of-p occ2)))))) - - -;;;;;;;;;;;;;;;;; -;; -;; TopicC - -(elephant:defpclass TopicC (ReifiableConstructC) - ((topic-identifiers - :accessor topic-identifiers - :associate (TopicIdentificationC identified-construct)) - (psis ;accessor written below - :associate (PersistentIdC identified-construct) - :documentation "list of PSI objects associated with this - topic") - (locators - ;accessor written below - :associate (SubjectLocatorC identified-construct) - :documentation "an optional URL that (if given) means that this topic is a subject locator") - (names ;accessor written below - :associate (NameC topic) - :documentation "list of topic names (as TopicC objects)") - (occurrences ;accessor occurrences explicitly written below - :associate (OccurrenceC topic) - :documentation "list of occurrences (as OccurrenceC objects)") - (player-in-roles ;accessor player-in-roles written below - :associate (RoleC player) - :documentation "the list of all role instances where this topic is a player in") - (used-as-type ;accessor used-as-type written below - :associate (TypableC instance-of) - :documentation "list of all constructs that have this topic as their type") - (used-as-theme ;accessor used-as-theme written below - :associate (ScopableC themes) - :many-to-many t - :documentation "list of all scopable objects this topic is a theme in") - (in-topicmaps - :associate (TopicMapC topics) - :many-to-many t - :documentation "list of all topic maps this topic is part of") - (reified - :associate ReifiableConstructC - :documentation "contains a reified object, represented as 1:1 association")) - (:documentation "Topic in a Topic Map")) - - -(defgeneric reified (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (when (slot-boundp topic 'reified) - (slot-value topic 'reified)))) - -(defgeneric (setf reified) (reifiable ReifiableConstructC) - (:method (reifiable (topic TopicC)) - (setf (slot-value topic 'reified) reifiable))) -; (setf (reifier reifiable) topic))) - -(defgeneric occurrences (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision topic 'occurrences :start-revision revision))) - -(defgeneric names (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision topic 'names :start-revision revision))) - -(defgeneric psis (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision - topic 'psis :start-revision revision))) - -(defgeneric locators (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision - topic 'locators :start-revision revision))) - -(defgeneric player-in-roles (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision - topic 'player-in-roles :start-revision revision))) - -(defgeneric used-as-type (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision topic 'used-as-type :start-revision revision))) - -(defgeneric used-as-theme (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision topic 'used-as-theme :start-revision revision))) - -(defgeneric in-topicmaps (topic &key revision) - (:method ((topic TopicC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))) - -(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers)) - "Moves all identifiers from the source-topic to the destination topic." - (declare (TopicC destination-topic source-topic)) - (let ((all-source-identifiers - (cond - ((eql what 'item-identifiers) - (item-identifiers source-topic)) - ((eql what 'locators) - (locators source-topic)) - (t - (psis source-topic)))) - (all-destination-identifiers - (cond - ((eql what 'item-identifiers) - (item-identifiers destination-topic)) - ((eql what 'locators) - (locators destination-topic)) - ((eql what 'psis) - (psis destination-topic)) - ((eql what 'topic-identifiers) - (topic-identifiers destination-topic))))) - (let ((identifiers-to-move - (loop for id in all-source-identifiers - when (not (find-if #'(lambda(x) - (if (eql what 'topic-identifiers) - (string= (xtm-id x) (xtm-id id)) - (string= (uri x) (uri id)))) - all-destination-identifiers)) - collect id))) - (dolist (item identifiers-to-move) - (remove-association source-topic what item) - (add-association destination-topic what item))))) - -(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil)) - "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" - (declare (list psis)) - (declare (list locators)) + +(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))) + + +(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)) + + +(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*)) + "Returns the construct's parent corresponding to the given revision." + (let ((valid-associations + (filter-slot-value-by-revision construct 'parent + :start-revision revision))) + (when valid-associations + (parent-construct (first valid-associations))))) + + +(defmethod add-parent ((construct RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((already-set-parent (parent construct :revision revision)) + (same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct (parent-construct parent-assoc)) + return parent-assoc))) + (when (and already-set-parent + (not (eql already-set-parent parent-construct))) + (error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent) + construct (parent construct :revision revision) parent-construct))) + (let ((merged-role + (merge-if-equivalent construct parent-construct :revision revision))) + (if merged-role + merged-role + (progn + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc + :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc + :start-revision revision)) + (t + (make-construct 'RoleAssociationC + :role construct + :parent-construct parent-construct + :start-revision revision))) + (add-to-version-history parent-construct :start-revision revision) + construct))))) + + +(defmethod private-delete-parent ((construct RoleC) (parent-construct AssociationC) + &key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent)))) + (let ((assoc-to-delete + (loop for parent-assoc in (slot-p construct 'parent) + when (eql (parent-construct parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct))) + + +(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) + &key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent)))) + (when (private-delete-parent construct parent-construct :revision revision) + (add-to-version-history parent-construct :start-revision revision) + construct)) + + +(defgeneric player (construct &key revision) + (:documentation "Returns the construct's player corresponding to + the given revision.") + (:method ((construct RoleC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'player + :start-revision revision))) + (when valid-associations + (player-topic (first valid-associations)))))) + + +(defgeneric add-player (construct player-topic &key revision) + (:documentation "Adds a topic as a player to a role in the given revision.") + (:method ((construct RoleC) (player-topic TopicC) + &key (revision *TM-REVISION*)) + (let ((already-set-player (player construct :revision revision)) + (same-player-assoc + (loop for player-assoc in (slot-p construct 'player) + when (eql (player-topic player-assoc) player-topic) + return player-assoc))) + (when (and already-set-player + (not (eql already-set-player player-topic))) + (error (make-tm-reference-condition (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a" construct player-topic already-set-player) + construct (player construct :revision revision) player-topic))) + (cond (already-set-player + (let ((player-assoc + (loop for player-assoc in (slot-p construct 'player) + when (eql player-topic (player-topic player-assoc)) + return player-assoc))) + (add-to-version-history player-assoc :start-revision revision))) + (same-player-assoc + (add-to-version-history same-player-assoc :start-revision revision)) + (t + (make-construct 'PlayerAssociationC + :parent-construct construct + :player-topic player-topic + :start-revision revision)))) + construct)) + + +(defgeneric private-delete-player (construct player-topic &key revision) + (:documentation "Deletes the passed topic as a player of the passed role + object by marking its association-object as deleted.") + (:method ((construct RoleC) (player-topic TopicC) + &key (revision (error (make-missing-argument-condition "From private-delete-player(): revision must be set" 'revision 'private-delete-player)))) + (let ((assoc-to-delete + (loop for player-assoc in (slot-p construct 'player) + when (eql (parent-construct player-assoc) construct) + return player-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-player (construct player-topic &key revision) + (:documentation "See delete-player but adds the parent role to + the given version.") + (:method ((construct RoleC) (player-topic TopicC) + &key (revision (error (make-missing-argument-condition "From delete-player(): revision must be set" 'revision 'delete-player)))) + (when (private-delete-player construct player-topic :revision revision) + (let ((assoc (parent construct :revision revision))) + (when assoc + (add-role assoc construct :revision revision) + construct))))) + + +;;; ReifiableConstructC +(defmethod mark-as-deleted :around ((construct ReifiableConstructC) + &key source-locator revision) + "Marks all item-identifiers of a given reifiable-construct as deleted." + (declare (ignorable source-locator)) (call-next-method) - ;item-identifiers are handled in the around-method for ReifiableConstructs, - ;TopicIdentificationCs are handled in make-construct of TopicC - (dolist (persistent-id psis) - (declare (PersistentIdC persistent-id)) - (setf (identified-construct persistent-id) instance)) - (dolist (subject-locator locators) - (declare (SubjectLocatorC subject-locator)) - (setf (identified-construct subject-locator) instance)) - (when reified - (setf (reified instance) reified))) + (dolist (ii (item-identifiers construct :revision 0)) + (private-delete-item-identifier construct ii :revision revision))) -(defmethod delete-construct :before ((construct TopicC)) - (dolist (dependent (append (topic-identifiers construct) - (psis construct) - (locators construct) - (names construct) - (occurrences construct) - (player-in-roles construct) - (used-as-type construct))) - (delete-construct dependent)) - (dolist (theme (used-as-theme construct)) - (elephant:remove-association construct 'used-as-theme theme)) - (dolist (tm (in-topicmaps construct)) - (elephant:remove-association construct 'in-topicmaps tm)) - (when (reified construct) - (slot-makunbound (reified construct) 'reifier))) - -(defun get-all-constructs-by-uri (uri) - (delete - nil - (mapcar - (lambda (identifier) - (and - (slot-boundp identifier 'identified-construct) - (identified-construct identifier))) - (union - (union - (elephant:get-instances-by-value 'ItemIdentifierC 'uri uri) - (elephant:get-instances-by-value 'PersistentIdC 'uri uri)) - (elephant:get-instances-by-value 'SubjectLocatorC 'uri uri))))) +(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (dolist (id (get-all-identifiers-of-construct construct :revision revision)) + (when (> + (length + (delete-if-not #'(lambda(identifier) + (or (typep identifier 'PersistentIdC) + (typep identifier 'SubjectLocatorC) + (typep identifier 'ItemIdentifierC))) + (union + (elephant:get-instances-by-value + 'ItemIdentifierC 'uri (uri id)) + (union + (elephant:get-instances-by-value + 'PersistentIdC 'uri (uri id)) + (elephant:get-instances-by-value + 'SubjectLocatorC 'uri (uri id)))))) + 1) + (error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id)))))) + + +(defgeneric ReifiableConstructC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to ReifiableConstructC + or one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'ReifiableconstructC) + (TopicMapC-p class-symbol) + (TopicC-p class-symbol) + (AssociationC-p class-symbol) + (RoleC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + +(defgeneric complete-reifiable (construct item-identifiers reifier + &key start-revision) + (:documentation "Adds all item-identifiers and the reifier to the passed + construct.") + (:method ((construct ReifiableConstructC) item-identifiers reifier + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision) (list item-identifiers) + (type (or null TopicC) reifier)) + (let ((merged-construct construct)) + (dolist (ii item-identifiers) + (setf merged-construct + (add-item-identifier merged-construct ii + :revision start-revision))) + (when reifier + (setf merged-construct (add-reifier merged-construct reifier + :revision start-revision))) + merged-construct))) + + +(defgeneric equivalent-reifiable-construct (construct reifier item-identifiers + &key start-revision) + (: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 *TM-REVISION*)) + (declare (integer start-revision) (list item-identifiers) + (type (or null TopicC) reifier)) + (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))))) -(defun find-existing-topic (item-identifiers locators psis) - (let - ((uris - (mapcar #'uri - (union (union item-identifiers locators) psis))) - (existing-topics nil)) - (dolist (uri uris) - (setf existing-topics - (nunion existing-topics - (get-all-constructs-by-uri uri) - :key #'internal-id))) - (assert (<= (length existing-topics) 1)) - (first existing-topics))) +(defmethod delete-construct :before ((construct ReifiableConstructC)) + (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)))))) -(defmethod make-construct ((class-symbol (eql 'TopicC)) &rest args - &key start-revision item-identifiers locators psis topicid xtm-id) - (let - ((existing-topic - (find-existing-topic item-identifiers locators psis))) - (if existing-topic - (progn - ;our problem with topics is that we know only after the - ;addition of all the identifiers and characteristics if - ;anything has changed. We can't decide that here, so we must - ;add all revisions (real or imaginary) to version history - ;and decide the rest in changed-p. Maybe somebody can think - ;of a better way? - (add-to-version-history existing-topic - :start-revision start-revision) - (init-topic-identification existing-topic topicid xtm-id - :revision start-revision) - (let* ;add new identifiers to existing topics - ((all-new-identifiers - (union (union item-identifiers locators) psis)) - (all-existing-identifiers - (get-all-identifiers-of-construct existing-topic))) - (mapc - (lambda (identifier) - (setf (identified-construct identifier) existing-topic)) - (set-difference all-new-identifiers all-existing-identifiers - :key #'uri :test #'string=)) - (mapc #'delete-construct - (delete-if - (lambda (identifier) - (slot-boundp identifier 'identified-construct)) - all-new-identifiers))) - (check-for-duplicate-identifiers existing-topic) - existing-topic) - (progn - (let* - ((cleaned-args (remove-nil-values args)) - (new-topic - (apply #'make-instance 'TopicC cleaned-args))) - - (init-topic-identification new-topic topicid xtm-id - :revision start-revision) - (check-for-duplicate-identifiers new-topic) - (add-to-version-history new-topic - :start-revision start-revision) - new-topic))))) - -(defmethod make-construct :around ((class-symbol (eql 'TopicC)) - &key start-revision &allow-other-keys) - (declare (ignorable start-revision)) - (call-next-method)) +(defgeneric item-identifiers (construct &key revision) + (:documentation "Returns the ItemIdentifierC-objects that correspond + with the passed construct and the passed version.") + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'item-identifiers :start-revision revision))) + (map 'list #'identifier assocs)))) - -(defmethod equivalent-constructs ((topic1 TopicC) (topic2 TopicC)) - "TMDM, 5.3.5: Equality rule: Two topic items are equal if they have: -* at least one equal string in their [subject identifiers] properties, +(defgeneric reifier (construct &key revision) + (:documentation "Returns the reifier-topic that corresponds + with the passed construct and the passed version.") + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (let ((assocs (filter-slot-value-by-revision + construct 'reifier :start-revision revision))) + (when assocs ;assocs must be nil or a list with exactly one item + (reifier-topic (first assocs)))))) + + +(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 + construct a new revision is added. + If the passed identifer already identifies another object + the identified-constructs are merged.") + (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) + &key (revision *TM-REVISION*)) + (let ((all-ids + (map 'list #'identifier (slot-p construct 'item-identifiers))) + (construct-to-be-merged + (let ((id-owner (identified-construct item-identifier + :revision revision))) + (when (not (eql id-owner construct)) + id-owner)))) + (when (and construct-to-be-merged + (not (eql (type-of construct-to-be-merged) + (type-of construct)))) + (error (make-not-mergable-condition (format nil "From add-item-identifier(): ~a and ~a can't be merged since the identified-constructs are not of the same type" + construct construct-to-be-merged) + construct construct-to-be-merged))) + (let ((merged-construct construct)) + (cond (construct-to-be-merged + (setf merged-construct + (merge-constructs construct construct-to-be-merged + :revision revision))) + ((find item-identifier all-ids) + (let ((ii-assoc + (loop for ii-assoc in (slot-p construct 'item-identifiers) + when (eql (identifier ii-assoc) item-identifier) + return ii-assoc))) + (add-to-version-history ii-assoc :start-revision revision))) + (t + (make-construct 'ItemIdAssociationC + :parent-construct construct + :identifier item-identifier + :start-revision revision))) + (add-version-info construct revision) + merged-construct)))) + + +(defgeneric private-delete-item-identifier (construct item-identifier + &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) + &key (revision (error (make-missing-argument-condition "From private-delete-item-identifier(): revision must be set" 'revision 'private-delete-item-identifier)))) + (let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers) + when (eql (identifier ii-assoc) item-identifier) + return ii-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-item-identifier (construct item-identifier + &key revision) + (:documentation "See private-delete-item-identifier but adds the parent + construct to the given version.") + (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) + &key (revision (error (make-missing-argument-condition "From delete-item-identifier(): revision must be set" 'revision 'delete-item-identifier)))) + (when (private-delete-item-identifier construct item-identifier + :revision revision) + (add-version-info construct revision) + construct))) -* at least one equal string in their [item identifiers] properties, -* at least one equal string in their [subject locators] properties, +(defgeneric add-reifier (construct reifier-topic &key revision) + (:documentation "Adds the passed reifier-topic as reifier of the construct. + If the construct is already reified by the given topic + there only is added a new version-info. + If the reifier-topic reifies already another construct + the reified-constructs are merged.") + (:method ((construct ReifiableConstructC) (reifier-topic TopicC) + &key (revision *TM-REVISION*)) + (when (and (reified-construct reifier-topic :revision revision) + (not (equivalent-constructs construct + (reified-construct + reifier-topic :revision revision)))) + (error (make-not-mergable-condition (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable" + reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct) + construct (reified-construct reifier-topic :revision revision)))) + (let ((merged-reifier-topic + (if (reifier construct :revision revision) + (merge-constructs (reifier construct :revision revision) + reifier-topic) + reifier-topic))) + (let ((all-constructs (map 'list #'reifiable-construct + (slot-p reifier-topic 'reified-construct)))) + (let ((merged-construct construct)) + (cond ((reified-construct merged-reifier-topic :revision revision) + (let ((merged-reified + (merge-constructs + (reified-construct merged-reifier-topic + :revision revision) construct))) + (setf merged-construct merged-reified))) + ((find construct all-constructs) + (let ((reifier-assoc + (loop for reifier-assoc in + (slot-p merged-reifier-topic 'reified-construct) + when (eql (reifiable-construct reifier-assoc) + construct) + return reifier-assoc))) + (add-to-version-history reifier-assoc + :start-revision revision))) + (t + (make-construct 'ReifierAssociationC + :reifiable-construct construct + :reifier-topic merged-reifier-topic + :start-revision revision))) + (add-version-info construct revision) + merged-construct))))) + + +(defgeneric private-delete-reifier (construct reifier &key revision) + (:documentation "Sets the association object between the passed constructs + as mark-as-deleted.") + (:method ((construct ReifiableConstructC) (reifier TopicC) + &key (revision (error (make-missing-argument-condition "From private-delete-reifier(): revision must be set" 'revision 'private-delete-reifier)))) + (let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier) + when (eql (reifier-topic reifier-assoc) reifier) + return reifier-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-reifier (construct reifier &key revision) + (:documentation "See private-delete-reifier but adds the reified-construct + to the given version.") + (:method ((construct ReifiableConstructC) (reifier TopicC) + &key (revision (error (make-missing-argument-condition "From delete-reifier(): revision must be set" 'revision 'delete-reifier)))) + (when (private-delete-reifier construct reifier :revision revision) + (add-version-info construct revision) + construct))) -* an equal string in the [subject identifiers] property of the one -topic item and the [item identifiers] property of the other, or the -same information item in their [reified] properties (TODO: this rule -is currently ignored)" - ;(declare (optimize (debug 3))) - (let - ((psi-uris1 - (map 'list #'uri (psis topic1))) - (psi-uris2 - (map 'list #'uri (psis topic2))) - (ii-uris1 - (map 'list #'uri (item-identifiers topic1))) - (ii-uris2 - (map 'list #'uri (item-identifiers topic2))) - (locators1 - (map 'list #'uri (locators topic1))) - (locators2 - (map 'list #'uri (locators topic2)))) - (let - ((all-uris1 - (union psi-uris1 (union ii-uris1 locators1) :test #'string=)) - (all-uris2 - (union psi-uris2 (union ii-uris2 locators2) :test #'string=))) - ;;TODO: consider what we should do about this. If the topic at a - ;;given revision doesn't exist yet, it correctly has no uris - ;;(for that version) - ;; (when (= 0 (length all-uris1)) -;; (error (make-condition 'no-identifier-error :message "Topic1 has no identifier" :internal-id (internal-id topic1)))) -;; (when (= 0 (length all-uris2)) -;; (error (make-condition 'no-identifier-error :message "Topic2 has no identifier" :internal-id (internal-id topic2)))) - (intersection - all-uris1 all-uris2 - :test #'string=)))) - -(defmethod get-all-identifiers-of-construct ((top TopicC)) - (append (psis top) - (locators top) - (item-identifiers top))) - -(defmethod topicid ((top TopicC) &optional (xtm-id nil)) - "Return the primary id of this item (= essentially the OID). If -xtm-id is explicitly given, return one of the topicids in that -TM (which must then exist)" - (if xtm-id - (let - ((possible-identifications - (remove-if-not - (lambda (top-id) - (string= (xtm-id top-id) xtm-id)) - (elephant:get-instances-by-value - 'TopicIdentificationC - 'identified-construct - top)))) - (unless possible-identifications - (error (make-condition - 'object-not-found-error - :message - (format nil "Could not find an object ~a in xtm-id ~a" top xtm-id)))) - (uri (first possible-identifications))) - (format nil "t~a" - (internal-id top)))) - +(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (item-identifiers construct :revision revision)) -(defgeneric psis-p (top) - (:documentation "Test for the existence of PSIs") - (:method ((top TopicC)) (slot-predicate top 'psis))) -(defgeneric list-instanceOf (topic &key tm) - (:documentation "Generate a list of all topics that this topic is an - instance of, optionally filtered by a topic map")) +;;; TypableC +(defgeneric TypableC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to TypableC or + one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'TypableC) + (AssociationC-p class-symbol) + (RoleC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + +(defgeneric complete-typable (construct instance-of &key start-revision) + (:documentation "Adds the passed instance-of to the given construct.") + (:method ((construct TypableC) instance-of + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision) (type (or null TopicC) instance-of)) + (when instance-of + (add-type construct instance-of :revision start-revision)) + construct)) -(defmethod list-instanceOf ((topic TopicC) &key (tm nil)) - (remove-if - #'null - (map 'list #'(lambda(x) - (when (loop for psi in (psis (instance-of x)) - when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance") - return t) - (loop for role in (roles (parent x)) - when (not (eq role x)) - return (player role)))) - (if tm - (remove-if-not - (lambda (role) - ;(format t "player: ~a" (player role)) - ;(format t "parent: ~a" (parent role)) - ;(format t "topic: ~a~&" topic) - (in-topicmap tm (parent role))) - (player-in-roles topic)) - (player-in-roles topic))))) +(defgeneric equivalent-typable-construct (construct instance-of + &key start-revision) + (: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 *TM-REVISION*)) + (declare (integer start-revision) + (type (or null TopicC) instance-of)) + (eql (instance-of construct :revision start-revision) instance-of))) + + +;;; ScopableC +(defgeneric ScopableC-p (class-symbol) + (:documentation "Returns t if the passed class is equal to ScopableC or + one of its subtypes.") + (:method ((class-symbol symbol)) + (or (eql class-symbol 'ScopableC) + (AssociationC-p class-symbol) + (CharacteristicC-p class-symbol)))) + + +(defgeneric complete-scopable (construct themes &key start-revision) + (:documentation "Adds all passed themes to the given construct.") + (:method ((construct ScopableC) (themes list) + &key (start-revision *TM-REVISION*)) + (declare (integer start-revision)) + (dolist (theme themes) + (add-theme construct theme :revision start-revision)) + construct)) -(defgeneric list-super-types (topic &key tm) - (:documentation "Generate a list of all topics that this topic is an - subclass of, optionally filtered by a topic map")) +(defgeneric equivalent-scopable-construct (construct themes &key start-revision) + (: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 *TM-REVISION*)) + (declare (integer start-revision) (list themes)) + (not (set-exclusive-or (themes construct :revision start-revision) + themes)))) -(defmethod list-super-types ((topic TopicC) &key (tm nil)) - (remove-if - #'null - (map 'list #'(lambda(x) - (when (loop for psi in (psis (instance-of x)) - when (string= (uri psi) *subtype-psi*) - return t) - (loop for role in (roles (parent x)) - when (not (eq role x)) - return (player role)))) - (if tm - (remove-if-not - (lambda (role) - (format t "player: ~a" (player role)) - (format t "parent: ~a" (parent role)) - (format t "topic: ~a~&" topic) - (in-topicmap tm (parent role))) - (player-in-roles topic)) - (player-in-roles topic))))) +(defmethod delete-construct :before ((construct ScopableC)) + (dolist (scope-assoc-to-delete (slot-p construct 'themes)) + (delete-construct scope-assoc-to-delete))) -(defun string-starts-with (str prefix) - "Checks if string str starts with a given prefix" - (declare (string str prefix)) - (string= str prefix :start1 0 :end1 - (min (length prefix) - (length str)))) +(defgeneric themes (construct &key revision) + (:documentation "Returns all topics that correspond with the given revision + as a scope for the given topic.") + (:method ((construct ScopableC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'themes + :start-revision revision))) + (map 'list #'theme-topic valid-associations)))) + + +(defgeneric add-theme (construct theme-topic &key revision) + (:documentation "Adds the given theme-topic to the passed + scopable-construct.") + (:method ((construct ScopableC) (theme-topic TopicC) + &key (revision *TM-REVISION*)) + (let ((all-themes + (map 'list #'theme-topic (slot-p construct 'themes)))) + (if (find theme-topic all-themes) + (let ((theme-assoc + (loop for theme-assoc in (slot-p construct 'themes) + when (eql (theme-topic theme-assoc) theme-topic) + return theme-assoc))) + (add-to-version-history theme-assoc :start-revision revision)) + (make-construct 'ScopeAssociationC + :theme-topic theme-topic + :scopable-construct construct + :start-revision revision))) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) + construct)) -(defun get-item-by-item-identifier (uri &key revision) - "get a construct by its item identifier. Returns nil if the item does not exist in a -particular revision" - (declare (string uri)) - (declare (integer revision)) - (let - ((ii-obj - (elephant:get-instance-by-value 'ItemIdentifierC - 'uri uri))) - (when ii-obj - (find-item-by-revision - (identified-construct ii-obj) revision)))) +(defgeneric private-delete-theme (construct theme-topic &key revision) + (:documentation "Deletes the passed theme by marking it's association as + deleted in the passed revision.") + (:method ((construct ScopableC) (theme-topic TopicC) + &key (revision (error (make-missing-argument-condition "From private-delete-theme(): revision must be set" 'revision 'private-delete-theme)))) + (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes) + when (eql (theme-topic theme-assoc) theme-topic) + return theme-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-theme (construct theme-topic &key revision) + (:documentation "See private-delete-theme but adds the parent construct + to the given version.") + (:method ((construct ScopableC) (theme-topic TopicC) + &key (revision (error (make-missing-argument-condition "From delete-theme(): revision must be set" 'revision 'delete-theme)))) + (when (private-delete-theme construct theme-topic :revision revision) + (add-version-info construct revision) + construct))) -(defun get-item-by-psi (psi &key (revision 0)) - "get a topic by its PSI. Returns nil if the item does not exist in a -particular revision" - (declare (string psi)) - (declare (integer revision)) - (let - ((psi-obj - (elephant:get-instance-by-value 'PersistentIdC - 'uri psi))) - (when psi-obj - (find-item-by-revision - (identified-construct psi-obj) revision)))) - -(defun get-item-by-id (topicid &key (xtm-id *current-xtm*) (revision 0) (error-if-nil nil)) - "get a topic by its id, assuming a xtm-id. If xtm-id is empty, the current TM -is chosen. If xtm-id is nil, choose the global TM with its internal ID, if -applicable in the correct revision. If revison is provided, then the code checks -if the topic already existed in this revision and returns nil otherwise. -If no item meeting the constraints was found, then the return value is either -NIL or an error is thrown, depending on error-if-nil." + +;;; 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-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.") + (:method ((construct TypableC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'instance-of + :start-revision revision))) + (when valid-associations + (type-topic (first valid-associations)))))) + + +(defgeneric add-type (construct type-topic &key revision) + (:documentation "Add the passed type-topic as type to the given + typed construct if there is no other type-topic + set at the same revision.") + (:method ((construct TypableC) (type-topic TopicC) + &key (revision *TM-REVISION*)) + (let ((already-set-type (instance-of construct :revision revision)) + (same-type-assoc + (loop for type-assoc in (slot-p construct 'instance-of) + when (eql (type-topic type-assoc) type-topic) + return type-assoc))) + (when (and already-set-type + (not (eql type-topic already-set-type))) + (error (make-tm-reference-condition (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a" + construct type-topic already-set-type) + construct (instance-of construct :revision revision) type-topic))) + (cond (already-set-type + (let ((type-assoc + (loop for type-assoc in (slot-p construct 'instance-of) + when (eql type-topic (type-topic type-assoc)) + return type-assoc))) + (add-to-version-history type-assoc :start-revision revision))) + (same-type-assoc + (add-to-version-history same-type-assoc :start-revision revision)) + (t + (make-construct 'TypeAssociationC + :type-topic type-topic + :typable-construct construct + :start-revision revision)))) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) + construct)) + + +(defgeneric private-delete-type (construct type-topic &key revision) + (:documentation "Deletes the passed type by marking it's association as + deleted in the passed revision.") + (:method ((construct TypableC) (type-topic TopicC) + &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type)))) + (let ((assoc-to-delete + (loop for type-assoc in (slot-p construct 'instance-of) + when (eql (type-topic type-assoc) type-topic) + return type-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision) + construct)))) + + +(defgeneric delete-type (construct type-topic &key revision) + (:documentation "See private-delete-type but adds the parent construct + to the given version.") + (:method ((construct TypableC) (type-topic TopicC) + &key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type)))) + (when (private-delete-type construct type-topic :revision revision) + (add-version-info construct revision) + construct))) + + +;;; TopicMapC +(defmethod equivalent-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC) + &key (revision *TM-REVISION*)) (declare (integer revision)) - (let - ((result - (if xtm-id - (let - ((possible-items - (delete-if-not - (lambda (top-id) - (and - (string= (xtm-id top-id) xtm-id) - (string= (uri top-id) topicid))) ;fixes a bug in - ;get-instances-by-value - ;that does a - ;case-insensitive - ;comparision - (elephant:get-instances-by-value - 'TopicIdentificationC - 'uri - topicid)))) - (when (and possible-items - (identified-construct-p (first possible-items))) - (unless (= (length possible-items) 1) - (error (make-condition 'duplicate-identifier-error - :message - (format nil "(length possible-items ~a) for id ~a und xtm-id ~a > 1" possible-items topicid xtm-id) - :uri topicid))) - (let - ((found-topic - (identified-construct (first possible-items)))) - (if (= revision 0) - found-topic - (find-item-by-revision found-topic revision))))) - (elephant::controller-recreate-instance elephant:*store-controller* (subseq topicid 1))))) - (if (and error-if-nil (not result)) - (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision)) - result))) + (when (intersection (item-identifiers construct-1 :revision revision) + (item-identifiers construct-2 :revision revision)) + t)) - -;;;;;;;;;;;;;;;;;; -;; -;; RoleC - -(elephant:defpclass RoleC (ReifiableConstructC TypableC) - ((parent :accessor parent - :initarg :parent - :associate AssociationC - :documentation "Association that this role belongs to") - (player :accessor player - :initarg :player - :associate TopicC - :documentation "references the topic that is the player in this role")) - (:documentation "The role that this topic plays in an association (formerly member)")) +(defgeneric TopicMapC-p (class-symbol) + (:documentation "Returns t if the passed symbol is equal to TopicMapC.") + (:method ((class-symbol symbol)) + (eql class-symbol 'TopicMapC))) -(defgeneric RoleC-p (object) - (:documentation "test if object is a of type RoleC") - (:method ((object t)) nil) - (:method ((object RoleC)) object)) - - -(defgeneric parent-p (vi) - (:documentation "t if this construct has a parent construct") - (:method ((constr RoleC)) (slot-predicate constr 'parent))) +(defmethod equivalent-construct ((construct TopicMapC) + &key (start-revision *TM-REVISION*) + (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 RoleC)) - ;the way we use roles, we cannot just delete the parent association - ;(at least the second role won't have one left then and will - ;complain) - (delete-1-n-association construct 'parent) - (delete-1-n-association construct 'player)) +(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))) -(defmethod find-all-equivalent ((construct RoleC)) - (let - ((parent (and (slot-boundp construct 'parent) - (parent construct)))) - (when parent - (delete-if-not #'(lambda (cand) (strictly-equivalent-constructs construct cand)) - (slot-value parent 'roles))))) - - -(defmethod equivalent-constructs ((role1 RoleC) (role2 RoleC)) - "Association role items are equal if the values of their [type], [player], and [parent] properties are equal (TMDM 5.8)" - ;for the purposes for which we use this method (namely the - ;construction of associations), roles will initially always be - ;unequal regarding their parent properties - (and - (= (internal-id (instance-of role1)) (internal-id (instance-of role2))) - (= (internal-id (player role1)) (internal-id (player role2))))) - - -;;;;;;;;;;;;;;;;;; -;; -;; AssociationC - -(elephant:defpclass AssociationC (ReifiableConstructC ScopableC TypableC) - ((roles :accessor roles - :associate (RoleC parent) - :documentation "(non-empty) list of this association's roles") - (in-topicmaps - :associate (TopicMapC associations) - :many-to-many t - :documentation "list of all topic maps this association is part of")) - (:documentation "Association in a Topic Map") - (:index t)) +(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) + (add-association construct 'topics construct-to-add) + construct-to-add) -(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*)) - (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) +(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC)) + (add-association construct 'associations construct-to-add) + construct-to-add) -(defgeneric AssociationC-p (object) - (:documentation "test if object is a of type AssociationC") - (:method ((object t)) nil) - (:method ((object AssociationC)) object)) +(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) + (remove-association construct 'topics construct-to-delete)) -(defmethod initialize-instance :around ((instance AssociationC) - &key - (roles nil)) - "implements the pseudo-initarg :roles" - (declare (list roles)) - (let - ((association (call-next-method))) - (dolist (role-data roles) - (make-instance - 'RoleC - :instance-of (getf role-data :instance-of) - :player (getf role-data :player) - :item-identifiers (getf role-data :item-identifiers) - :reifier (getf role-data :reifier) - :parent association)))) - -(defmethod make-construct :around ((class-symbol (eql 'AssociationC)) - &key - start-revision - &allow-other-keys) - (declare (ignorable start-revision)) - (let - ((association - (call-next-method))) - (declare (AssociationC association)) - (dolist (role (slot-value association 'roles)) - (unless (versions role) - (add-to-version-history role - :start-revision start-revision))) - association)) - -(defmethod copy-item-identifiers :around - ((from-construct AssociationC) - (to-construct AssociationC)) - "Internal method to copy over item idenfiers from one association -with its roles to another one. Role identifiers are also -copied. Returns nil if neither association nor role identifiers had to be copied" - (let - ((item-identifiers-copied-p nil)) ;rather brutal solution. find a better one - (when (call-next-method) - (setf item-identifiers-copied-p t)) - (do ((from-roles (roles from-construct) (rest from-roles)) - (to-roles (roles to-construct) (rest to-roles))) - ((null from-roles) 'finished) - (let - ((from-role (first from-roles)) - (to-role (first to-roles))) - (when - (mapc - (lambda (identifier) - (setf (identified-construct identifier) - to-role)) - (set-difference (item-identifiers from-role) - (item-identifiers to-role) - :key #'uri :test #'string=)) - (setf item-identifiers-copied-p t)))) - item-identifiers-copied-p)) -(defmethod delete-construct :before ((construct AssociationC)) - (dolist (role (roles construct)) - (delete-construct role)) - (dolist (tm (in-topicmaps construct)) - (elephant:remove-association construct 'in-topicmaps tm))) +(defmethod delete-from-tm ((construct TopicMapC) + (construct-to-delete AssociationC)) + (remove-association construct 'associations construct-to-delete)) -(defmethod find-all-equivalent ((construct AssociationC)) - (let - ((some-player (player (or - (second (roles construct)) - (first (roles construct)))))) ;; dirty, dirty... but brings a tenfold speedup! - (delete-if-not - #'(lambda (cand) - (unless (eq construct cand) - (equivalent-constructs construct cand))) - ;here we need to use the "internal" API and access the players - ;with slot-value (otherwise we won't be able to merge with - ;'deleted' associations) - (mapcar #'parent (slot-value some-player 'player-in-roles))))) - - -(defmethod equivalent-constructs ((assoc1 AssociationC) (assoc2 AssociationC)) - "Association items are equal if the values of their [scope], [type], and [roles] properties are equal (TMDM 5.7)" - (and - (= (internal-id (instance-of assoc1)) (internal-id (instance-of assoc2))) - (not (set-exclusive-or (themes assoc1) (themes assoc2) - :key #'internal-id)) - (not (set-exclusive-or - (roles assoc1) - (roles assoc2) - :test #'equivalent-constructs)))) - - -(elephant:defpclass TopicMapC (ReifiableConstructC) - ((topics :accessor topics - :associate (TopicC in-topicmaps) - :documentation "list of topics that explicitly belong to this TM") - (associations :accessor associations - :associate (AssociationC in-topicmaps) - :documentation "list of associations that belong to this TM")) - (:documentation "Topic Map")) - -(defmethod equivalent-constructs ((tm1 TopicMapC) (tm2 TopicMapC)) - "Topic Map items are equal if one of their identifiers is equal" - ;Note: TMDM does not make any statement to this effect, but it's the - ;one logical assumption - (intersection - (item-identifiers tm1) - (item-identifiers tm2) - :test #'equivalent-constructs)) - -(defmethod find-all-equivalent ((construct TopicMapC)) - (let - ((tms (elephant:get-instances-by-class 'd:TopicMapC))) - (delete-if-not - (lambda(tm) - (strictly-equivalent-constructs construct tm)) - tms))) - -(defgeneric add-to-topicmap (tm top) - (:documentation "add a topic or an association to a topic - map. Return the added construct")) - -(defmethod add-to-topicmap ((tm TopicMapC) (top TopicC)) - ;TODO: add logic not to add pure topic stubs unless they don't exist yet in the store -; (elephant:add-association tm 'topics top) ;by adding the elephant association in this order, there will be missing one site of this association - (elephant:add-association top 'in-topicmaps tm) - top) - -(defmethod add-to-topicmap ((tm TopicMapC) (ass AssociationC)) - ;(elephant:add-association tm 'associations ass) - (elephant:add-association ass 'in-topicmaps tm) - ass) -(defgeneric in-topicmap (tm constr &key revision) - (:documentation "Is a given construct (topic or assiciation) in this topic map?")) +(defgeneric in-topicmap (tm construct &key revision) + (:documentation "Is a given construct (topic or assiciation) in this + topic map?")) + -(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0)) +(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key + (revision *TM-REVISION*)) (when (find-item-by-revision top revision) - (find (d:internal-id top) (d:topics tm) :test #'= :key #'d:internal-id))) + (find (internal-id top) (topics tm) :test #'= :key #'internal-id))) -(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0)) +(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) + &key (revision *TM-REVISION*)) (when (find-item-by-revision ass revision) - (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id))) + (find (internal-id ass) (associations tm) :test #'= :key #'internal-id))) -;;;;;;;;;;;;;;;;; -;; reification -(defgeneric add-reifier (construct reifier-topic) - (:method ((construct ReifiableConstructC) reifier-topic) - (let ((err "From add-reifier(): ")) - (declare (TopicC reifier-topic)) - (cond - ((and (not (reifier construct)) - (not (reified reifier-topic))) - (setf (reifier construct) reifier-topic) - (setf (reified reifier-topic) construct)) - ((and (not (reified reifier-topic)) - (reifier construct)) - (merge-reifier-topics (reifier construct) reifier-topic)) - ((and (not (reifier construct)) - (reified reifier-topic)) - (error "~a~a ~a reifies already another object ~a" - err (psis reifier-topic) (item-identifiers reifier-topic) - (reified reifier-topic))) - (t - (when (not (eql (reified reifier-topic) construct)) - (error "~a~a ~a reifies already another object ~a" - err (psis reifier-topic) (item-identifiers reifier-topic) - (reified reifier-topic))) - (merge-reifier-topics (reifier construct) reifier-topic))) - construct))) +;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun make-construct (class-symbol &rest args) + "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." + (declare (symbol class-symbol)) + (when (and (or (VersionedConstructC-p class-symbol) + (and (ReifiableConstructC-p class-symbol) + (or (getf args :item-identifiers) (getf args :reifier)))) + (not (getf args :start-revision))) + (error (make-missing-argument-condition "From make-construct(): start-revision must be set" 'start-revision 'make-construct))) + (let ((construct + (cond + ((PointerC-p class-symbol) + (apply #'make-pointer class-symbol args)) + ((CharacteristicC-p class-symbol) + (apply #'make-characteristic class-symbol args)) + ((TopicC-p class-symbol) + (apply #'make-topic args)) + ((TopicMapC-p class-symbol) + (apply #'make-tm args)) + ((RoleC-p class-symbol) + (apply #'make-role args)) + ((AssociationC-p class-symbol) + (apply #'make-association args)) + ((VersionedConstructC-p class-symbol) + (apply #'make-instance class-symbol + (rec-remf args :start-revision))) + (t + (apply #'make-instance class-symbol args)))) + (start-revision (or (getf args :start-revision) *TM-REVISION*))) + (when (typep construct 'TypableC) + (complete-typable construct (getf args :instance-of) + :start-revision start-revision)) + (when (typep construct 'ScopableC) + (complete-scopable construct (getf args :themes) + :start-revision start-revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision start-revision)) + (when (or (typep construct 'TopicC) (typep construct 'AssociationC)) + (dolist (tm (getf args :in-topicmaps)) + (add-to-tm tm construct))) + (if (typep construct 'ReifiableConstructC) + (complete-reifiable construct (getf args :item-identifiers) + (getf args :reifier) :start-revision start-revision) + construct))) + + +(defun make-association (&rest args) + "Returns an association object. If the association has already existed the + existing one is returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((instance-of (getf args :instance-of)) + (start-revision (getf args :start-revision)) + (themes (getf args :themes)) + (roles (getf args :roles))) + (when (and (or roles instance-of themes) + (not start-revision)) + (error (make-missing-argument-condition "From make-association(): start-revision must be set" 'start-revision 'make-association))) + (let ((association + (let ((existing-associations + (remove-if + #'null + (map 'list #'(lambda(existing-association) + (when (equivalent-construct + existing-association + :start-revision start-revision + :roles roles :themes themes + :instance-of instance-of) + existing-association)) + (get-all-associations nil))))) + (cond ((> (length existing-associations) 1) + (merge-all-constructs existing-associations + :revision start-revision)) + (existing-associations + (first existing-associations)) + (t + (make-instance 'AssociationC)))))) + (dolist (role-plist roles) + (add-role association + (apply #'make-construct 'RoleC + (append role-plist (list :parent association))) + :revision (getf role-plist :start-revision))) + association))) + + +(defun make-role (&rest args) + "Returns a role object. If the role has already existed the + existing one is returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((parent (getf args :parent)) + (instance-of (getf args :instance-of)) + (player (getf args :player)) + (start-revision (getf args :start-revision))) + (when (and (or instance-of player parent) + (not start-revision)) + (error (make-missing-argument-condition "From make-role(): start-revision must be set" 'start-revision 'make-role))) + (let ((role + (let ((existing-roles + (when parent + (remove-if + #'null + (map 'list #'(lambda(existing-role) + (when (equivalent-construct + existing-role + :start-revision start-revision + :player player + :instance-of instance-of) + existing-role)) + (map 'list #'role (slot-p parent 'roles))))))) + (if (and existing-roles + (or (eql parent (parent (first existing-roles) + :revision start-revision)) + (not (parent (first existing-roles) + :revision start-revision)))) + (progn + (add-role parent (first existing-roles) + :revision start-revision) + (first existing-roles)) + (make-instance 'RoleC))))) + (when player + (add-player role player :revision start-revision)) + (when parent + (add-parent role parent :revision start-revision)) + role))) + + +(defun make-tm (&rest args) + "Returns a topic map object. If the topic map has already existed the + existing one is returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((item-identifiers (getf args :item-identifiers)) + (reifier (getf args :reifier)) + (topics (getf args :topics)) + (assocs (getf args :associations)) + (start-revision (getf args :start-revision))) + (when (and (or item-identifiers reifier) + (not start-revision)) + (error (make-missing-argument-condition "From make-tm(): start-revision must be set" 'start-revision 'make-tm))) + (let ((tm + (let ((existing-tms + (remove-if + #'null + (map 'list #'(lambda(existing-tm) + (when (equivalent-construct + existing-tm + :item-identifiers item-identifiers + :reifier reifier) + existing-tm)) + (get-all-tms start-revision))))) + (cond ((> (length existing-tms) 1) + (merge-all-constructs existing-tms :revision start-revision)) + (existing-tms + (first existing-tms)) + (t + (make-instance 'TopicMapC)))))) + (dolist (top-or-assoc (union topics assocs)) + (add-to-tm tm top-or-assoc)) + tm))) + + +(defun make-topic (&rest args) + "Returns a topic object. If the topic has already existed the existing one is + returned otherwise a new one is created. + This function exists only for being used by make-construct!" + (let ((start-revision (getf args :start-revision)) + (psis (getf args :psis)) + (locators (getf args :locators)) + (item-identifiers (getf args :item-identifiers)) + (topic-identifiers (getf args :topic-identifiers)) + (names (getf args :names)) + (occurrences (getf args :occurrences)) + (reified-construct (getf args :refied-construct))) + (when (and (or psis locators item-identifiers topic-identifiers + names occurrences) + (not start-revision)) + (error (make-missing-argument-condition "From make-topic(): start-revision must be set" 'start-revision 'make-topic))) + (let ((topic + (let ((existing-topics + (remove-if + #'null + (map 'list #'(lambda(existing-topic) + (when (equivalent-construct + existing-topic + :start-revision start-revision + :psis psis :locators locators + :item-identifiers item-identifiers + :topic-identifiers topic-identifiers) + existing-topic)) + (get-all-topics start-revision))))) + (cond ((> (length existing-topics) 1) + (merge-all-constructs existing-topics :revision start-revision)) + (existing-topics + (first existing-topics)) + (t + (make-instance 'TopicC)))))) + (let ((merged-topic topic)) + (dolist (tid topic-identifiers) + (setf merged-topic (add-topic-identifier merged-topic tid + :revision start-revision))) + (dolist (psi psis) + (setf merged-topic (add-psi merged-topic psi + :revision start-revision))) + (dolist (locator locators) + (setf merged-topic (add-locator merged-topic locator + :revision start-revision))) + (dolist (name names) + (setf merged-topic (add-name merged-topic name + :revision start-revision))) + (dolist (occ occurrences) + (add-occurrence merged-topic occ :revision start-revision)) + (when reified-construct + (add-reified-construct merged-topic reified-construct + :revision start-revision)) + merged-topic)))) + + +(defun make-characteristic (class-symbol &rest args) + "Returns a characteristic object with the passed parameters. + If an equivalent construct has already existed this one is returned. + To check if there is existing an equivalent construct the parameter + parent-construct must be set. + This function only exists for being used by make-construct!" + (let ((charvalue (or (getf args :charvalue) "")) + (start-revision (getf args :start-revision)) + (datatype (or (getf args :datatype) *xml-string*)) + (instance-of (getf args :instance-of)) + (themes (getf args :themes)) + (variants (getf args :variants)) + (parent (getf args :parent))) + (when (and (or instance-of themes variants parent) + (not start-revision)) + (error (make-missing-argument-condition "From make-characteristic(): start-revision must be set" 'start-revision 'make-characgteristic))) + (let ((characteristic + (let ((existing-characteristics + (when parent + (remove-if + #'null + (map 'list #'(lambda(existing-characteristic) + (when (equivalent-construct + existing-characteristic + :start-revision start-revision + :datatype datatype :variants variants + :charvalue charvalue :themes themes + :instance-of instance-of) + existing-characteristic)) + (get-all-characteristics parent class-symbol)))))) + (if (and existing-characteristics + (or (eql parent (parent (first existing-characteristics) + :revision start-revision)) + (not (parent (first existing-characteristics) + :revision start-revision)))) + (progn + (add-characteristic parent (first existing-characteristics) + :revision start-revision) + (first existing-characteristics)) + (make-instance class-symbol :charvalue charvalue + :datatype datatype))))) + (when (typep characteristic 'NameC) + (complete-name characteristic variants :start-revision start-revision)) + (when parent + (add-parent characteristic parent :revision start-revision)) + characteristic))) + + +(defun make-pointer (class-symbol &rest args) + "Returns a pointer object with the specified parameters. + If an equivalen construct has already existed this one is returned. + This function only exists for beoing used by make-construct!" + (let ((uri (getf args :uri)) + (xtm-id (getf args :xtm-id)) + (start-revision (getf args :start-revision)) + (identified-construct (getf args :identified-construct)) + (err "From make-pointer(): ")) + (when (and identified-construct (not start-revision)) + (error (make-missing-argument-condition (format nil "~astart-revision must be set" err) 'start-revision 'make-pointer))) + (unless uri + (error (make-missing-argument-condition (format nil "~auri must be set" err) 'uri 'make-pointer))) + (when (and (TopicIdentificationC-p class-symbol) + (not xtm-id)) + (error (make-missing-argument-condition (format nil "~axtm-id must be set" err) 'xtm-id 'make-pointer))) + (let ((identifier + (let ((existing-pointer + (remove-if + #'null + (map 'list + #'(lambda(existing-pointer) + (when (and (typep existing-pointer class-symbol) + (equivalent-construct existing-pointer + :uri uri + :xtm-id xtm-id)) + existing-pointer)) + (elephant:get-instances-by-value class-symbol 'd::uri uri))))) + (if existing-pointer + (first existing-pointer) + (make-instance class-symbol :uri uri :xtm-id xtm-id))))) + (when identified-construct + (cond ((TopicIdentificationC-p class-symbol) + (add-topic-identifier identified-construct identifier + :revision start-revision)) + ((PersistentIdC-p class-symbol) + (add-psi identified-construct identifier :revision start-revision)) + ((ItemIdentifierC-p class-symbol) + (add-item-identifier identified-construct identifier + :revision start-revision)) + ((SubjectLocatorC-p class-symbol) + (add-locator identified-construct identifier + :revision start-revision)))) + identifier))) + + +;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric move-identifiers (source destination &key revision) + (:documentation "Sets all identifiers as mark as deleted in the given + version and adds the marked identifiers to the + destination construct.")) + + +(defmethod move-identifiers ((source ReifiableConstructC) + (destination ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((iis (item-identifiers source :revision revision))) + (dolist (ii iis) + (private-delete-item-identifier source ii :revision revision) + (add-item-identifier destination ii :revision revision)) + iis)) -(defgeneric remove-reifier (construct) - (:method ((construct ReifiableConstructC)) - (let ((reifier-topic (reifier construct))) - (when reifier-topic - (elephant:remove-association construct 'reifier reifier-topic) - (elephant:remove-association reifier-topic 'reified construct))))) - - -(defgeneric merge-reifier-topics (old-topic new-topic) - ;;the reifier topics are not only merged but also bound to the reified-construct - (:method ((old-topic TopicC) (new-topic TopicC)) - (unless (eql old-topic new-topic) - ;merges all identifiers - (move-identifiers old-topic new-topic) - (move-identifiers old-topic new-topic :what 'locators) - (move-identifiers old-topic new-topic :what 'psis) - (move-identifiers old-topic new-topic :what 'topic-identifiers) - ;merges all typed-object-associations - (dolist (typed-construct (used-as-type new-topic)) - (remove-association typed-construct 'instance-of new-topic) - (add-association typed-construct 'instance-of old-topic)) - ;merges all scope-object-associations - (dolist (scoped-construct (used-as-theme new-topic)) - (remove-association scoped-construct 'themes new-topic) - (add-association scoped-construct 'themes old-topic)) - ;merges all topic-maps - (dolist (tm (in-topicmaps new-topic)) - (add-association tm 'topics old-topic)) ;the new-topic is removed from this tm by deleting it - ;merges all role-players - (dolist (a-role (player-in-roles new-topic)) - (remove-association a-role 'player new-topic) - (add-association a-role 'player old-topic)) - ;merges all names - (dolist (name (names new-topic)) - (remove-association name 'topic new-topic) - (add-association name 'topic old-topic)) - ;merges all occurrences - (dolist (occurrence (occurrences new-topic)) - (remove-association occurrence 'topic new-topic) - (add-association occurrence 'topic old-topic)) - ;merges all version-infos - (let ((versions-to-move - (loop for vrs in (versions new-topic) - when (not (find-if #'(lambda(x) - (and (= (start-revision x) (start-revision vrs)) - (= (end-revision x) (end-revision vrs)))) - (versions old-topic))) - collect vrs))) - (dolist (vrs versions-to-move) - (remove-association vrs 'versioned-construct new-topic) - (add-association vrs 'versioned-construct old-topic))) - (delete-construct new-topic)) - ;TODO: order/repair all version-infos of the topic itself and add all new - ; versions to the original existing objects of the topic - old-topic)) \ No newline at end of file +(defmethod move-identifiers ((source TopicC) (destination TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((iis (call-next-method)) + (tids (topic-identifiers source :revision revision)) + (psis (psis source :revision revision)) + (sls (locators source :revision revision))) + (dolist (tid tids) + (private-delete-topic-identifier source tid :revision revision) + (add-topic-identifier destination tid :revision revision)) + (dolist (psi psis) + (private-delete-psi source psi :revision revision) + (add-psi destination psi :revision revision)) + (dolist (sl sls) + (private-delete-locator source sl :revision revision) + (add-locator destination sl :revision revision)) + (append tids iis psis sls))) + + +(defgeneric move-referenced-constructs (source destination &key revision) + (:documentation "Moves all referenced constructs in the given version from + the source TM-construct to the destination TM-construct.")) + + +(defmethod move-referenced-constructs ((source ReifiableConstructC) + (destination ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (remove-if + #'null + (append + (move-identifiers source destination :revision revision) + (let ((source-reifier (reifier source :revision revision)) + (destination-reifier (reifier destination :revision revision))) + (let ((result + (cond ((and source-reifier destination-reifier) + (private-delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (private-delete-reifier (reified-construct destination-reifier + :revision revision) + destination-reifier :revision revision) + (let ((merged-reifier + (merge-constructs source-reifier destination-reifier + :revision revision))) + (add-reifier destination merged-reifier :revision revision) + merged-reifier)) + (source-reifier + (private-delete-reifier (reified-construct source-reifier + :revision revision) + source-reifier :revision revision) + (add-reifier destination source-reifier :revision revision) + source-reifier) + (destination-reifier + (add-reifier destination destination-reifier :revision revision) + nil)))) + (when result + (list result))))))) + + +(defmethod move-referenced-constructs ((source NameC) (destination NameC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (append (call-next-method) + (move-variants source destination :revision revision))) + + +(defmethod move-referenced-constructs ((source TopicC) (destination TopicC) + &key (revision *TM-REVISION*)) + (let ((roles (player-in-roles source :revision revision)) + (scopables (used-as-theme source :revision revision)) + (typables (used-as-type source :revision revision)) + (ids (move-identifiers source destination :revision revision))) + (dolist (role roles) + (private-delete-player role source :revision revision) + (add-player role destination :revision revision)) + (dolist (scopable scopables) + (private-delete-theme scopable source :revision revision) + (add-theme scopable destination :revision revision)) + (dolist (typable typables) + (private-delete-type typable source :revision revision) + (add-type typable destination :revision revision)) + (remove-if #'null (append roles scopables typables ids)))) + + +(defgeneric move-reified-construct (source destination &key revision) + (:documentation "Moves the refied TM-construct from the source topic + to the given destination topic.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((source-reified (reified-construct source :revision revision)) + (destination-reified (reified-construct destination + :revision revision))) + (when (and source-reified destination-reified + (not (eql (type-of source-reified) + (type-of destination-reified)))) + (error (make-not-mergable-condition (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" + source destination source-reified destination-reified) + source destination))) + (cond ((and source-reified destination-reified) + (private-delete-reifier source-reified source :revision revision) + (private-delete-reifier destination-reified destination :revision revision) + (let ((merged-reified + (merge-constructs source-reified destination-reified + :revision revision))) + (add-reifier merged-reified destination :revision revision) + merged-reified)) + (source-reified + (private-delete-reifier source source-reified :revision revision) + (add-reifier source-reified destination :revision revision) + source-reified) + (destination-reified + (add-reifier destination-reified destination :revision revision) + destination-reified))))) + + +(defgeneric move-occurrences (source destination &key revision) + (:documentation "Moves all occurrences from the source topic to the + destination topic. If occurrences are TMDM equal + they are merged, i.e. one is marked-as-deleted.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((occs-to-move (occurrences source :revision revision))) + (dolist (occ occs-to-move) + (private-delete-occurrence source occ :revision revision) + (let ((equivalent-occ + (find-if #'(lambda (destination-occ) + (when + (strictly-equivalent-constructs + occ destination-occ :revision revision) + destination-occ)) + (occurrences destination :revision revision)))) + (if equivalent-occ + (progn + (add-occurrence destination equivalent-occ :revision revision) + (move-referenced-constructs occ equivalent-occ + :revision revision)) + (add-occurrence destination occ :revision revision)))) + occs-to-move))) + + +(defgeneric move-variants (source destination &key revision) + (:documentation "Moves all variants from the source name to the destination + name. If any variants are TMDM equal they are merged --> + i.e. one of the variants is marked-as-deleted.") + (:method ((source NameC) (destination NameC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((vars-to-move (variants source :revision revision))) + (dolist (var vars-to-move) + (private-delete-variant source var :revision revision) + (let ((equivalent-var + (find-if #'(lambda (destination-var) + (when + (strictly-equivalent-constructs + var destination-var :revision revision) + destination-var)) + (variants destination :revision revision)))) + (if equivalent-var + (progn + (add-variant destination equivalent-var :revision revision) + (move-referenced-constructs var equivalent-var + :revision revision)) + (add-variant destination var :revision revision)))) + vars-to-move))) + + +(defgeneric move-names (source destination &key revision) + (:documentation "Moves all names from the source topic to the destination + topic. If any names are equal they are merged, i.e. + one of the names is marked-as-deleted.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((names-to-move (names source :revision revision))) + (dolist (name names-to-move) + (private-delete-name source name :revision revision) + (let ((equivalent-name + (find-if #'(lambda (destination-name) + (when + (strictly-equivalent-constructs + name destination-name :revision revision) + destination-name)) + (names destination :revision revision)))) + (if equivalent-name + (progn + (add-name destination equivalent-name :revision revision) + (move-referenced-constructs name equivalent-name + :revision revision)) + (add-name destination name :revision revision)))) + names-to-move))) + + +(defun merge-changed-constructs (older-topic &key (revision *TM-REVISION*)) + (declare (TopicC older-topic)) + (dolist (construct (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision) + (player-in-roles older-topic :revision revision))) + (let ((parent (when (or (typep construct 'RoleC) + (typep construct 'CharacteristicC)) + (parent construct :revision revision)))) + (let ((all-other (cond ((typep construct 'OccurrenceC) + (occurrences parent :revision revision)) + ((typep construct 'NameC) + (names parent :revision revision)) + ((typep construct 'VariantC) + (variants parent :revision revision)) + ((typep construct 'RoleC) + (roles parent :revision revision))))) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(other) + (when (strictly-equivalent-constructs + construct other :revision revision) + other)) + all-other)))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list construct)) + :revision revision)))))) + (merge-changed-associations older-topic :revision revision)) + + +(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) + "Merges all associations that became TMDM-equal since two referenced topics + were merged, e.g. the association types." + (declare (TopicC older-topic)) + (let ((all-assocs + (remove-duplicates + (append + (remove-if + #'null + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles older-topic :revision revision))) + (remove-if + #'null + (map + 'list #'(lambda(constr) + (when (typep constr 'AssociationC) + constr)) + (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision)))))))) + (dolist (assoc all-assocs) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(db-assoc) + (when (strictly-equivalent-constructs + assoc db-assoc :revision revision) + db-assoc)) + (get-all-associations nil))))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list assoc)) + :revision revision)))))) + + +(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) + &key (revision *TM-REVISION*)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-topic (find-oldest-construct construct-1 construct-2))) + (let ((newer-topic (if (eql older-topic construct-1) + construct-2 + construct-1))) + (dolist (tm (in-topicmaps newer-topic :revision revision)) + (add-to-tm tm older-topic)) + (move-names newer-topic older-topic :revision revision) + (move-occurrences newer-topic older-topic :revision revision) + (move-referenced-constructs newer-topic older-topic :revision revision) + (move-reified-construct newer-topic older-topic :revision revision) + (merge-changed-constructs older-topic :revision revision) + (mark-as-deleted newer-topic :revision revision :source-locator nil) + (when (exist-in-version-history-p newer-topic) + (delete-construct newer-topic)) + older-topic)))) + + +(defmethod merge-constructs ((construct-1 CharacteristicC) + (construct-2 CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-char (find-oldest-construct construct-1 construct-2))) + (let ((newer-char (if (eql older-char construct-1) + construct-2 + construct-1))) + (let ((parent-1 (parent older-char :revision revision)) + (parent-2 (parent newer-char :revision revision))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) + construct-1 construct-2))) + (cond ((and parent-1 (eql parent-1 parent-2)) + (move-referenced-constructs newer-char older-char + :revision revision) + (private-delete-characteristic parent-2 newer-char + :revision revision) + (let ((c-assoc + (find-if + #'(lambda(c-assoc) + (and (eql (characteristic c-assoc) older-char) + (eql (parent-construct c-assoc) parent-1))) + (cond ((typep older-char 'OccurrenceC) + (slot-p parent-1 'occurrences)) + ((typep older-char 'NameC) + (slot-p parent-1 'names)) + ((typep older-char 'VariantC) + (slot-p parent-1 'variants)))))) + (add-to-version-history c-assoc :start-revision revision)) + older-char) + ((and parent-1 parent-2) + (let ((active-parent (merge-constructs parent-1 parent-2 + :revision revision))) + (let ((found-older-char + (cond ((typep older-char 'OccurrenceC) + (find older-char + (occurrences + active-parent :revision revision))) + ((typep older-char 'NameC) + (find older-char + (names + active-parent :revision revision))) + ((typep older-char 'VariantC) + (find-if + #'(lambda(name) + (find older-char + (variants name + :revision revision))) + (if (parent active-parent :revision revision) + (names (parent active-parent :revision revision) + :revision revision) + (list active-parent))))))) + (if found-older-char + older-char + newer-char)))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-char newer-char)) + (src (if parent-1 newer-char older-char))) + (move-referenced-constructs src dst :revision revision) + (delete-if-not-referenced src) + dst)) + (t + (move-referenced-constructs newer-char older-char + :revision revision) + (delete-if-not-referenced newer-char) + older-char))))))) + + +(defmethod merge-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-tm (find-oldest-construct construct-1 construct-2))) + (let ((newer-tm (if (eql older-tm construct-1) + construct-2 + construct-1))) + (move-referenced-constructs newer-tm older-tm :revision revision) + (dolist (top-or-assoc (append (topics newer-tm) (associations newer-tm))) + (add-to-tm older-tm top-or-assoc)) + (add-to-version-history older-tm :start-revision revision) + (mark-as-deleted newer-tm :revision revision) + (when (exist-in-version-history-p newer-tm) + (delete-construct newer-tm)) + older-tm)))) + + +(defmethod merge-constructs ((construct-1 AssociationC) (construct-2 AssociationC) + &key revision) + (declare (integer revision)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-assoc (find-oldest-construct construct-1 construct-2))) + (let ((newer-assoc (if (eql older-assoc construct-1) + construct-2 + construct-1))) + ;(unless (strictly-equivalent-constructs construct-1 construct-2 + ; :revision revision) + ;;associations that have different roles can be although merged, e.g. + ;;two roles are in two different association objects references + ;;the same item-identifier or reifier + (when (or (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision)) + (not (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)))) + (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) + construct-1 construct-2))) + (dolist (tm (in-topicmaps newer-assoc :revision revision)) + (add-to-tm tm older-assoc)) + (private-delete-type newer-assoc (instance-of newer-assoc :revision revision) + :revision revision) + (move-referenced-constructs newer-assoc older-assoc) + (dolist (newer-role (roles newer-assoc :revision revision)) + (let ((equivalent-role + (find-if #'(lambda(older-role) + (strictly-equivalent-constructs + older-role newer-role :revision revision)) + (roles older-assoc :revision revision)))) + (when equivalent-role + (move-referenced-constructs newer-role equivalent-role + :revision revision)) + (private-delete-role newer-assoc newer-role :revision revision) + (add-role older-assoc (if equivalent-role + equivalent-role + newer-role) + :revision revision))) + (mark-as-deleted newer-assoc :revision revision) + (when (exist-in-version-history-p newer-assoc) + (delete-construct newer-assoc)) + older-assoc)))) + + +(defmethod merge-constructs ((construct-1 RoleC) (construct-2 RoleC) + &key (revision *TM-REVISION*)) + (declare (integer *TM-REVISION*)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-role (find-oldest-construct construct-1 construct-2))) + (let ((newer-role (if (eql older-role construct-1) + construct-2 + construct-1))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) + construct-1 construct-2))) + (let ((parent-1 (parent older-role :revision revision)) + (parent-2 (parent newer-role :revision revision))) + (cond ((and parent-1 (eql parent-1 parent-2)) + (move-referenced-constructs newer-role older-role + :revision revision) + (private-delete-role parent-2 newer-role :revision revision) + (let ((r-assoc + (find-if + #'(lambda(r-assoc) + (and (eql (role r-assoc) older-role) + (eql (parent-construct r-assoc) parent-1))) + (slot-p parent-1 'roles)))) + (add-to-version-history r-assoc :start-revision revision) + older-role)) + ((and parent-1 parent-2) + (let ((active-assoc (merge-constructs parent-1 parent-2 + :revision revision))) + (if (find older-role (roles active-assoc + :revision revision)) + older-role + newer-role))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-role newer-role)) + (src (if parent-1 newer-role older-role))) + (move-referenced-constructs src dst :revision revision) + (delete-if-not-referenced src) + dst)) + (t + (move-referenced-constructs newer-role older-role + :revision revision) + (delete-if-not-referenced newer-role) + older-role))))))) + + +(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((possible-roles + (remove-if #'(lambda(role) + (when (parent role :revision revision) + role)) + (map 'list #'role (slot-p parent-construct 'roles))))) + (let ((equivalent-role + (remove-if + #'null + (map 'list + #'(lambda(role) + (when + (strictly-equivalent-constructs role new-role + :revision revision) + role)) + possible-roles)))) + (when equivalent-role + (merge-constructs (first equivalent-role) new-role + :revision revision))))) + + +(defmethod merge-if-equivalent ((new-characteristic CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or TopicC NameC) parent-construct)) + (let ((all-existing-characteristics + (map 'list #'characteristic + (cond ((typep new-characteristic 'OccurrenceC) + (slot-p parent-construct 'occurrences)) + ((typep new-characteristic 'NameC) + (slot-p parent-construct 'names)) + ((typep new-characteristic 'VariantC) + (slot-p parent-construct 'variants)))))) + (let ((possible-characteristics ;all characteristics that are not referenced + ;other constructs at the given revision + (remove-if #'(lambda(char) + (parent char :revision revision)) + all-existing-characteristics))) + (let ((equivalent-construct + (remove-if + #'null + (map 'list + #'(lambda(char) + (when + (strictly-equivalent-constructs char new-characteristic + :revision revision) + char)) + possible-characteristics)))) + (when equivalent-construct + (merge-constructs (first equivalent-construct) new-characteristic + :revision revision)))))) \ No newline at end of file Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Sun Oct 10 05:41:19 2010 @@ -13,7 +13,10 @@ :missing-reference-error :no-identifier-error :duplicate-identifier-error - :object-not-found-error)) + :object-not-found-error + :not-mergable-error + :missing-argument-error + :tm-reference-error)) (in-package :exceptions) @@ -22,6 +25,7 @@ :initarg :message :accessor message))) + (define-condition missing-reference-error(error) ((message :initarg :message @@ -31,6 +35,7 @@ :initarg :reference)) (:documentation "thrown is a reference is missing")) + (define-condition duplicate-identifier-error(error) ((message :initarg :message @@ -40,12 +45,14 @@ :initarg :reference)) (:documentation "thrown if the same identifier is already in use")) + (define-condition object-not-found-error(error) ((message :initarg :message :accessor message)) (:documentation "thrown if the object could not be found")) + (define-condition no-identifier-error(error) ((message :initarg :message @@ -54,3 +61,48 @@ :initarg :internal-id :accessor internal-id)) (:documentation "thrown if the topic has no identifier")) + + +(define-condition not-mergable-error (error) + ((message + :initarg :message + :accessor message) + (construc-1 + :initarg :construct-1 + :accessor construct-1) + (construc-2 + :initarg :construct-2 + :accessor construct-2)) + (:documentation "Thrown if two constructs are not mergable since + they have e.g. difference types.")) + + +(define-condition missing-argument-error (error) + ((message + :initarg :message + :accessor message) + (argument-symbol + :initarg :argument-symbol + :accessor argument-symbol) + (function-symbol + :initarg :function-symbol + :accessor function-symbol)) + (:documentation "Thrown if a argument is missing in a function.")) + + +(define-condition tm-reference-error (error) + ((message + :initarg :message + :accessor message) + (referenced-construct + :initarg :referenced-construct + :accessor referenced-construct) + (existing-reference + :initarg :existing-reference + :accessor existing-reference) + (new-reference + :initarg :new-reference + :accessor new-reference)) + (:documentation "Thrown of the referenced-construct is already owned by another + TM-construct (existing-reference) and is going to be referenced + by a second TM-construct (new-reference) at the same time.")) \ No newline at end of file Modified: trunk/src/rest_interface/read.lisp ============================================================================== --- trunk/src/rest_interface/read.lisp (original) +++ trunk/src/rest_interface/read.lisp Sun Oct 10 05:41:19 2010 @@ -67,7 +67,7 @@ (source-locator (source-locator-prefix feed))) ;check if xtm-id has already been imported or if the entry is older ;than the snapshot feed. If so, don't do it again - (unless (or (xtm-id-p xtm-id) (string> (atom:updated entry) (atom:updated imported-snapshot-entry))) + (unless (or (string> (atom:updated entry) (atom:updated imported-snapshot-entry))) (when top (mark-as-deleted top :source-locator source-locator :revision revision)) ;(format t "Fragment feed: ~a~&" (link entry)) @@ -98,10 +98,11 @@ (find most-recent-update entry-list :key #'updated :test #'string=))) (defun most-recent-imported-snapshot (all-snapshot-entries) - (let - ((all-imported-entries - (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id))) - (most-recent-entry all-imported-entries))) +; (let +; ((all-imported-entries +; (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id))) +; (most-recent-entry all-imported-entries)) + (most-recent-entry all-snapshot-entries)) (defun import-snapshots-feed (snapshot-feed-url &key tm-id) "checks if we already imported any of this feed's snapshots. If not, Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Sun Oct 10 05:41:19 2010 @@ -40,8 +40,7 @@ :*ajax-user-interface-url* :*ajax-user-interface-file-path* :*ajax-javascript-directory-path* - :*ajax-javascript-url-prefix* - :*mark-as-deleted-url*)) + :*ajax-javascript-url-prefix*)) (in-package :rest-interface) @@ -63,7 +62,8 @@ (defvar *server-acceptor* nil) -(defun start-tm-engine (repository-path &key (conffile "atom/conf.lisp") (host-name "localhost") (port 8000)) +(defun start-tm-engine (repository-path &key (conffile "atom/conf.lisp") + (host-name "localhost") (port 8000)) "Start the Topic Map Engine on a given port, assuming a given hostname. Use the repository under repository-path" (when *server-acceptor* 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 Sun Oct 10 05:41:19 2010 @@ -26,7 +26,6 @@ (defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") ;the file path to the HTML file implements the user interface (defparameter *ajax-javascript-directory-path* "ajax/javascripts") ;the directory which contains all necessary javascript files (defparameter *ajax-javascript-url-prefix* "/javascripts") ; the url prefix of all javascript files -(defparameter *mark-as-deleted-url* "/mark-as-deleted") ; the url suffix that calls the mark-as-deleted handler (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*) (get-rdf-prefix *get-rdf-prefix*) @@ -44,8 +43,7 @@ (ajax-user-interface-css-prefix *ajax-user-interface-css-prefix*) (ajax-user-interface-css-directory-path *ajax-user-interface-css-directory-path*) (ajax-javascripts-directory-path *ajax-javascript-directory-path*) - (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) - (mark-as-deleted-url *mark-as-deleted-url*)) + (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -113,9 +111,6 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher json-get-summary-url #'return-topic-summaries) - hunchentoot:*dispatch-table*) - (push - (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler) hunchentoot:*dispatch-table*)) ;; ============================================================================= @@ -127,7 +122,7 @@ (declare (ignorable param)) (handler-case (let ((topic-types (with-reader-lock - (json-tmcl::return-all-tmcl-types)))) + (json-tmcl::return-all-tmcl-types :revision 0)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -138,6 +133,7 @@ (setf (hunchentoot:content-type*) "text") (format nil "Condition: \"~a\"" err))))) + (defun return-all-tmcl-instances(&optional param) "Returns all topic-psis that are valid instances of any topic type. The validity is only oriented on the typing of topics, e.g. @@ -145,7 +141,7 @@ (declare (ignorable param)) (handler-case (let ((topic-instances (with-reader-lock - (json-tmcl::return-all-tmcl-instances)))) + (json-tmcl::return-all-tmcl-instances :revision 0)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -164,8 +160,9 @@ (let ((topic (d:get-item-by-psi psi))) (if topic (let ((topic-json - (handler-case (with-reader-lock - (json-exporter::to-json-topicStub-string topic)) + (handler-case + (with-reader-lock + (json-exporter::to-json-topicStub-string topic :revision 0)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -184,25 +181,34 @@ (let ((http-method (hunchentoot:request-method*))) (if (or (eq http-method :POST) (eq http-method :PUT)) - (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) - (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) - (handler-case (let ((psis - (json:decode-json-from-string json-data))) - (let ((tmcl - (with-reader-lock - (json-tmcl:get-constraints-of-fragment psis :treat-as treat-as)))) - (if tmcl - (progn - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - tmcl) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) - (setf (hunchentoot:content-type*) "text") - (format nil "Topic \"~a\" not found." psis))))) - (condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) + (let ((external-format + (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) + (let ((json-data + (hunchentoot:raw-post-data :external-format external-format + :force-text t))) + (handler-case + (let ((psis + (json:decode-json-from-string json-data))) + (let ((tmcl + (with-reader-lock + (json-tmcl:get-constraints-of-fragment + psis :treat-as treat-as :revision 0)))) + (if tmcl + (progn + (setf (hunchentoot:content-type*) + "application/json") ;RFC 4627 + tmcl) + (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-not-found+) + (setf (hunchentoot:content-type*) "text") + (format nil "Topic \"~a\" not found." psis))))) + (condition (err) + (progn + (setf (hunchentoot:return-code*) + hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) @@ -215,7 +221,7 @@ (progn (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (handler-case (with-reader-lock - (get-all-topic-psis)) + (get-all-topic-psis :revision 0)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -235,7 +241,7 @@ (get-latest-fragment-of-topic identifier)))) (if fragment (handler-case (with-reader-lock - (to-json-string fragment)) + (to-json-string fragment :revision 0)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) @@ -302,12 +308,7 @@ (condition () nil)))) (handler-case (with-reader-lock (let ((topics - (remove-if - #'null - (map 'list #'(lambda(top) - (when (d:find-item-by-revision top 0) - top)) - (elephant:get-instances-by-class 'd:TopicC))))) + (elephant:get-instances-by-class 'd:TopicC))) (let ((end (cond ((not end-idx) @@ -342,40 +343,17 @@ "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) (with-reader-lock - (handler-case (let ((json-string - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) - - -(defun mark-as-deleted-handler (&optional param) - "Marks the corresponding elem as deleted. - {\"type\":<\"'TopicC\" | \"'OccurrenceC\" | \"'NameC\" - \"'AssociationC\" | \"'RoleC\" | \"VariantC\" >, - \"object\":<specified json-object: name or occurrence, - if the deleted object is a topic this field - has to be set to null>, - \"parent-topic\":<psis or null>, - \"parent-name\": <specified json-object: name>}." - (declare (ignorable param)) ;param is currently not used - (let ((http-method (hunchentoot:request-method*))) - (if (or (eq http-method :PUT) - (eq http-method :POST)) - (let ((external-format (flexi-streams:make-external-format :UTF-8 :eol-style :LF))) - (let ((json-data (hunchentoot:raw-post-data :external-format external-format :force-text t))) - (handler-case - (with-writer-lock - (json-tmcl::mark-as-deleted-from-json json-data)) - (condition (err) - (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err)))))) - (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) + (handler-case + (let ((json-string + (json-tmcl::tree-view-to-json-string + (json-tmcl::make-tree-view :revision 0)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) ;; ============================================================================= @@ -386,18 +364,22 @@ concatenated of the url-prefix and the relative path of all all files in the passed directory and its subdirectories" (let ((start-position-of-relative-path - (- (length (write-to-string (com.gigamonkeys.pathnames:file-exists-p path-to-files-directory))) 2))) + (- (length (write-to-string (com.gigamonkeys.pathnames:file-exists-p + path-to-files-directory))) 2))) (let ((files-and-urls nil)) - (com.gigamonkeys.pathnames:walk-directory path-to-files-directory - #'(lambda(current-path) - (let ((current-path-string - (write-to-string current-path))) - (let ((last-position-of-current-path - (- (length current-path-string) 1))) - (let ((current-url - (concatenate 'string url-prefix - (subseq current-path-string start-position-of-relative-path last-position-of-current-path)))) - (push (list :path current-path :url current-url) files-and-urls)))))) + (com.gigamonkeys.pathnames:walk-directory + path-to-files-directory + #'(lambda(current-path) + (let ((current-path-string + (write-to-string current-path))) + (let ((last-position-of-current-path + (- (length current-path-string) 1))) + (let ((current-url + (concatenate + 'string url-prefix + (subseq current-path-string start-position-of-relative-path + last-position-of-current-path)))) + (push (list :path current-path :url current-url) files-and-urls)))))) files-and-urls))) @@ -421,4 +403,4 @@ (setf ret-str (concatenate 'string ret-str (subseq str idx (1+ idx)))) (incf idx))) (unless (< idx (length str)) - (return ret-str))))))) \ No newline at end of file + (return ret-str))))))) Modified: trunk/src/unit_tests/atom_test.lisp ============================================================================== --- trunk/src/unit_tests/atom_test.lisp (original) +++ trunk/src/unit_tests/atom_test.lisp Sun Oct 10 05:41:19 2010 @@ -58,7 +58,7 @@ (atom:subfeeds atom:*tm-feed*) :test #'string= :key #'atom:id)) - (datetime-revision3 + (datetime-revision3 (atom::datetime-in-iso-format fixtures::revision3)) (datetime-revision1 (atom::datetime-in-iso-format fixtures::revision1)) @@ -66,7 +66,7 @@ (format nil "<a:feed xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Topicmaps on psi.egovpt.org</a:title><a:id>http://london.ztt.fh-worms.de:8000/feeds</a:id><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds\" rel=\"self\"></a:link><a:updated>~a</a:updated><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Data behind the portal of the city of Worms</a:title><a:id>http://psi.egovpt.org/tm/worms/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"alternate\" type=\"application/atom+xml\"></a:link><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"http://www.egovpt.org/sdshare/collectionfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>eGov Reference Ontology</a:title><a:id>http://psi.egovpt.org/tm/egov-ontology/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/egov-ontology\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/egov-ontology\" rel=\"alternate\" type=\"application/atom+xml\"></a:link><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/egov-ontology\" rel=\"http://www.egovpt.org/sdshare/collectionfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry></a:feed>" datetime-revision3 datetime-revision3 datetime-revision1)) (worms-feed-string (format nil "<a:feed xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Data behind the portal of the city of Worms</a:title><a:id>http://london.ztt.fh-worms.de:8000/feeds/worms</a:id><a:author><a:name>Isidor</a:name></a:author><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms\" rel=\"self\"></a:link><e:dependency>http://london.ztt.fh-worms.de:8000/feeds/egov-ontology</e:dependency><a:updated>~a</a:updated><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>Snapshots of the Worms data</a:title><a:id>http://psi.egovpt.org/tm/worms/snapshots/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots\" rel=\"http://www.egovpt.org/sdshare/snapshotsfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry><a:entry xmlns:a=\"http://www.w3.org/2005/Atom\" xmlns:e=\"http://www.egovpt.org/sdshare/\"><a:title>A list of all change fragments for the Worms data</a:title><a:id>http://psi.egovpt.org/tm/worms/fragments/entry</a:id><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/fragments\" rel=\"alternate\"></a:link><a:link href=\"http://london.ztt.fh-worms.de:8000/feeds/worms/fragments\" rel=\"http://www.egovpt.org/sdshare/fragmentsfeed\" type=\"application/atom+xml\"></a:link><a:updated>~a</a:updated></a:entry></a:feed>" datetime-revision3 datetime-revision3 datetime-revision3))) - (is + (is (string= collection-feed-string (cxml:with-xml-output @@ -103,9 +103,13 @@ (find 'atom::snapshots-feed (atom:subfeeds worms-feed) :key #'type-of))) + + (format t "~a~%~%~a~%" fragments-feed (map 'list #'atom::psi (atom:entries fragments-feed))) (is (= 11 (length (atom:entries fragments-feed)))) - (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments" (link fragments-feed))) - (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots" (link snapshots-feed))) + (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments" + (link fragments-feed))) + (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots" + (link snapshots-feed))) (format t "~a" (cxml:with-xml-output (cxml:make-string-sink :canonical t) Copied: trunk/src/unit_tests/datamodel_test.lisp (from r324, /branches/new-datamodel/src/unit_tests/datamodel_test.lisp) ============================================================================== --- /branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ trunk/src/unit_tests/datamodel_test.lisp Sun Oct 10 05:41:19 2010 @@ -599,13 +599,10 @@ (is-false (get-item-by-id "any-psi-id")) (signals object-not-found-error (get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0)) - (signals object-not-found-error - (get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0)) (is-false (get-item-by-psi "any-psi-id")) (add-psi top-1 psi-3-1 :revision rev-1) (add-psi top-1 psi-3-2 :revision rev-1) (is-false (get-item-by-locator "psi-3" :revision rev-1)) - (is-false (get-item-by-item-identifier "psi-3" :revision rev-1)) (signals duplicate-identifier-error (get-item-by-psi "psi-3" :revision rev-1)) (add-psi top-2 psi-1) Modified: trunk/src/unit_tests/exporter_xtm1.0_test.lisp ============================================================================== --- trunk/src/unit_tests/exporter_xtm1.0_test.lisp (original) +++ trunk/src/unit_tests/exporter_xtm1.0_test.lisp Sun Oct 10 05:41:19 2010 @@ -14,7 +14,8 @@ (test test-std-topics-xtm1.0 (with-fixture refill-test-db () (export-xtm *out-xtm1.0-file* :xtm-format '1.0) - (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) + (let ((document (dom:document-element + (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) (topic-counter 0)) (check-document-structure document 38 2 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") @@ -22,47 +23,74 @@ (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "subjectIdentity") *xtm1.0-ns* "subjectIndicatorRef") - do (let ((href (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href"))) + do (let ((href (dom:get-attribute-ns subjectIndicatorRef + *xtm1.0-xlink* "href"))) (cond ((string= core-topic-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-association-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-occurrence-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-class-instance-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-class-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-superclass-subclass-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-superclass-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-subclass-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-sort-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-display-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-type-instance-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-type-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))) ((string= core-instance-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "name"))))))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm1.0-ns* + "name"))))))) (is (= topic-counter 13))))) @@ -362,12 +390,10 @@ when (string= (uri item) psi) return (identified-construct item))) (t100-start-revision (d::start-revision (first (d::versions t100))))) - (d:get-fragments t100-start-revision) (let ((t100-fragment (loop for item in (elephant:get-instances-by-class 'FragmentC) when (eq (topic item) t100) return item))) - (with-open-file (stream *out-xtm1.0-file* :direction :output) (write-string (export-xtm-fragment t100-fragment :xtm-format '1.0) stream)))) @@ -415,7 +441,9 @@ (with-fixture merge-test-db () (handler-case (delete-file *out-xtm1.0-file*)(error () )) ;deletes file - if exist (export-xtm *out-xtm1.0-file* :revision fixtures::revision1 :xtm-format '1.0) - (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) + (let ((document + (dom:document-element + (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) (t100-occurrences-resourceData (list "The ISO 19115 standard ..." "2003-01-01"))) ;local value->no type (check-document-structure document 47 7 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") @@ -974,8 +1002,7 @@ (xpath-child-elems-by-qname name *xtm1.0-ns* "variant"))) (is (= (length variant-nodes) 1)) (elt variant-nodes 0)))) - (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi) - t101-variant-name nil))))) + (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi) t101-variant-name nil))))) (check-single-instanceOf document topic t3a-psi :xtm-format '1.0) (loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence") do (let ((instanceOf @@ -1090,27 +1117,27 @@ (test test-fragments-xtm1.0-versions (with-fixture merge-test-db () (handler-case (delete-file *out-xtm1.0-file*)(error () )) ;deletes file - if exist - - (let ((new-t100 (loop for item in (elephant:get-instances-by-class 'PersistentIdC) - when (string= (uri item) new-t100-psi) - return (identified-construct item)))) - + (let ((new-t100 + (loop for item in (elephant:get-instances-by-class 'd:PersistentIdC) + when (string= (uri item) new-t100-psi) + return (identified-construct item :revision fixtures::revision3)))) (d:get-fragments fixtures::revision3) - (let ((fragment (loop for item in (elephant:get-instances-by-class 'FragmentC) + (let ((fragment (loop for item in (elephant:get-instances-by-class 'd:FragmentC) when (eq (topic item) new-t100) return item))) - (with-open-file (stream *out-xtm1.0-file* :direction :output) (write-string (export-xtm-fragment fragment :xtm-format '1.0) stream)))) - - (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))) + (let ((document + (dom:document-element + (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))) (check-document-structure document 6 0 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") do (loop for subjectIndicatorRef across (xpath-child-elems-by-qname (xpath-single-child-elem-by-qname topic *xtm1.0-ns* "subjectIdentity") *xtm1.0-ns* "subjectIndicatorRef") - do (let ((href (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href"))) + do (let ((href (dom:get-attribute-ns subjectIndicatorRef + *xtm1.0-xlink* "href"))) (cond ((string= href core-sort-psi) (check-topic-id topic)) @@ -1125,28 +1152,35 @@ ((string= href new-t100-psi) (check-topic-id topic) (check-single-instanceOf document topic t3-psi :xtm-format '1.0) - (loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence") + (loop for occurrence across (xpath-child-elems-by-qname + topic *xtm1.0-ns* "occurrence") do (let ((resourceRef (let ((resourceRef-nodes - (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "resourceRef"))) + (xpath-child-elems-by-qname + occurrence *xtm1.0-ns* "resourceRef"))) (is (= (length resourceRef-nodes) 1)) - (dom:get-attribute-ns (elt resourceRef-nodes 0) *xtm1.0-xlink* "href"))) + (dom:get-attribute-ns (elt resourceRef-nodes 0) + *xtm1.0-xlink* "href"))) (instanceOf (let ((instanceOf-nodes - (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "instanceOf"))) + (xpath-child-elems-by-qname + occurrence *xtm1.0-ns* "instanceOf"))) (is (= (length instanceOf-nodes) 1)) (let ((topicRef-nodes (xpath-child-elems-by-qname - (elt instanceOf-nodes 0) *xtm1.0-ns* "topicRef"))) + (elt instanceOf-nodes 0) *xtm1.0-ns* + "topicRef"))) (is (= (length topicRef-nodes) 1)) (get-subjectIndicatorRef-by-ref document (dom:get-attribute-ns (elt topicRef-nodes 0) *xtm1.0-xlink* "href")))))) (cond - ((string= resourceRef (first new-t100-occurrence-resourceRef-merge-2)) + ((string= resourceRef + (first new-t100-occurrence-resourceRef-merge-2)) (is (string= instanceOf t55-psi))) - ((string= resourceRef (second new-t100-occurrence-resourceRef-merge-2)) + ((string= resourceRef + (second new-t100-occurrence-resourceRef-merge-2)) (is (string= instanceOf t55-psi))) (t (is-true Modified: trunk/src/unit_tests/exporter_xtm2.0_test.lisp ============================================================================== --- trunk/src/unit_tests/exporter_xtm2.0_test.lisp (original) +++ trunk/src/unit_tests/exporter_xtm2.0_test.lisp Sun Oct 10 05:41:19 2010 @@ -51,7 +51,8 @@ :test-exporter-xtm2.0-versions-1 :test-exporter-xtm2.0-versions-2 :test-exporter-xtm2.0-versions-3 :test-fragments-versions :test-exporter-xtm1.0-versions-1 :test-exporter-xtm1.0-versions-2 - :test-exporter-xtm1.0-versions-3 :test-fragments-xtm1.0-versions)) + :test-exporter-xtm1.0-versions-3 :test-fragments-xtm1.0-versions + :exporter-tests)) (in-package :exporter-test) (def-suite exporter-tests) @@ -69,7 +70,8 @@ (error () )) ;do nothing (handler-case (delete-file *out-xtm1.0-file*) (error () )) ;do nothing - (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm") + (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm" + :tm-id "http://isidorus.org/test-tm") (elephant:open-store (get-store-spec "data_base"))) @@ -551,52 +553,82 @@ (test test-std-topics (with-fixture refill-test-db () (export-xtm *out-xtm2.0-file*) - (let ((document (dom:document-element (cxml:parse-file *out-xtm2.0-file* (cxml-dom:make-dom-builder)))) + (let ((document (dom:document-element + (cxml:parse-file *out-xtm2.0-file* + (cxml-dom:make-dom-builder)))) (topic-counter 0)) (check-document-structure document 38 2) (loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic") - do (loop for subjectIdentifier across (xpath-child-elems-by-qname topic *xtm2.0-ns* "subjectIdentifier") - do (let ((href (dom:node-value (dom:get-attribute-node subjectIdentifier "href")))) + do (loop for subjectIdentifier across + (xpath-child-elems-by-qname topic *xtm2.0-ns* "subjectIdentifier") + do (let ((href (dom:node-value + (dom:get-attribute-node subjectIdentifier "href")))) (cond ((string= core-topic-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-association-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-occurrence-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-class-instance-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-class-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-superclass-subclass-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-superclass-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-subclass-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-sort-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-display-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-type-instance-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-type-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))) ((string= core-instance-psi href) (incf topic-counter) - (format t "name: ~A~%" (xpath-single-child-elem-by-qname topic *xtm2.0-ns* "name"))))))) + (format t "name: ~A~%" + (xpath-single-child-elem-by-qname topic *xtm2.0-ns* + "name"))))))) (is (= topic-counter 13))))) Modified: trunk/src/unit_tests/fixtures.lisp ============================================================================== --- trunk/src/unit_tests/fixtures.lisp (original) +++ trunk/src/unit_tests/fixtures.lisp Sun Oct 10 05:41:19 2010 @@ -37,7 +37,8 @@ :*XTM-MERGE1-TM* :*XTM-MERGE2-TM* :rdf-init-db - :rdf-test-db)) + :rdf-test-db + :with-empty-db)) (in-package :fixtures) @@ -93,14 +94,14 @@ (tear-down-test-db)) (def-fixture initialized-test-db (&optional (xtm *NOTIFICATIONBASE-TM*)) - (let - ((revision (get-revision))) + (let ((revision (get-revision))) (declare (ignorable revision)) + (setf *TM-REVISION* revision) (setf *XTM-TM* xtm) (set-up-test-db revision) - (let - ((tm - (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm" :revision (d:get-revision)))) + (let ((tm + (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm" + :revision revision))) (declare (ignorable tm)) (&body) (tear-down-test-db)))) @@ -210,4 +211,11 @@ (&body) (handler-case (delete-file exported-file-path) (error () )) ;do nothing - (tear-down-test-db))) \ No newline at end of file + (tear-down-test-db))) + + +(def-fixture with-empty-db (dir) + (clean-out-db dir) + (elephant:open-store (xml-importer:get-store-spec dir)) + (&body) + (tear-down-test-db)) \ No newline at end of file Modified: trunk/src/unit_tests/importer_test.lisp ============================================================================== --- trunk/src/unit_tests/importer_test.lisp (original) +++ trunk/src/unit_tests/importer_test.lisp Sun Oct 10 05:41:19 2010 @@ -22,7 +22,8 @@ xpath-select-location-path) (:import-from :exceptions missing-reference-error - duplicate-identifier-error) + duplicate-identifier-error + not-mergable-error ) (:export :importer-test :test-error-detection :run-importer-tests @@ -57,19 +58,19 @@ "Test the from-type-elem function of the importer" (with-fixture initialized-test-db() - (let - ((type-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "occurrence") - (*xtm2.0-ns* "type"))))) + (let ((type-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "occurrence") + (*xtm2.0-ns* "type")))) + (rev-1 *TM-REVISION*)) (loop for type-elem in type-elems do - (is (typep (from-type-elem type-elem) 'TopicC))) - (is-false (from-type-elem nil)) + (is (typep (from-type-elem type-elem rev-1) 'TopicC))) + (is-false (from-type-elem nil rev-1)) (let ((t100-occtype - (from-type-elem (first type-elems)))) + (from-type-elem (first type-elems) rev-1))) (format t "occtype: ~a~&" t100-occtype) (format t "occtype: ~a~&" (psis t100-occtype)) (is @@ -82,77 +83,74 @@ (declare (optimize (debug 3))) (with-fixture initialized-test-db() - (let - ((scope-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "name") - (*xtm2.0-ns* "scope"))))) + (let ((scope-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "name") + (*xtm2.0-ns* "scope")))) + (rev-1 *TM-REVISION*)) (loop for scope-elem in scope-elems do - (is (>= (length (from-scope-elem scope-elem)) 1))) - (is-false (from-scope-elem nil)) + (is (>= (length (from-scope-elem scope-elem rev-1)) 1))) + (is-false (from-scope-elem nil rev-1)) (let ((t101-themes - (from-scope-elem (first scope-elems)))) + (from-scope-elem (first scope-elems) rev-1))) (is (= 1 (length t101-themes))) (is (string= - (topicid (first t101-themes) *TEST-TM*) + (topic-id (first t101-themes) rev-1 *TEST-TM*) "t50a")))))) (test test-from-name-elem "Test the from-name-elem function of the importer" (with-fixture initialized-test-db() - (let - ((name-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "name")))) - (top (get-item-by-id "t1"))) ;an arbitrary topic + (let ((name-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "name")))) + (top (get-item-by-id "t1")) ;an arbitrary topic + (rev-1 *TM-REVISION*)) (loop for name-elem in name-elems do - (is (typep (from-name-elem name-elem top revision) 'NameC))) + (is (typep (from-name-elem name-elem top rev-1) 'NameC))) (let - ((t1-name (from-name-elem (first name-elems) top revision)) - (t1-name-copy (from-name-elem (first name-elems) top revision)) - (t101-longname (from-name-elem (nth 27 name-elems) top revision))) + ((t1-name (from-name-elem (first name-elems) top rev-1)) + (t1-name-copy (from-name-elem (first name-elems) top rev-1)) + (t101-longname (from-name-elem (nth 27 name-elems) top rev-1))) (is (string= (charvalue t1-name) "Topic Type")) - (is (string= - (charvalue t101-longname) - "ISO/IEC 13250:2002: Topic Maps")) - (is (= 1 (length (item-identifiers t101-longname)))) - - (is (string= - (uri (first (psis (instance-of t101-longname)))) - "http://psi.egovpt.org/types/long-name")) - (is (themes t101-longname)) + (is (string= (charvalue t101-longname) + "ISO/IEC 13250:2002: Topic Maps")) + (is (= 1 (length (item-identifiers t101-longname :revision rev-1)))) + (is (string= (uri (first (psis (instance-of t101-longname)))) + "http://psi.egovpt.org/types/long-name")) + (is (themes t101-longname :revision rev-1)) (is (string= - (topicid (first (themes t101-longname)) *TEST-TM*) + (topic-id (first (themes t101-longname :revision rev-1)) + rev-1 *TEST-TM*) "t50a")) - (is (eq t1-name t1-name-copy)) ;must be merged - )))) + (is (eq t1-name t1-name-copy)))))) ;must be merged + (test test-from-occurrence-elem "Test the form-occurrence-elem function of the importer" (with-fixture initialized-test-db() - (let - ((occ-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "occurrence")))) - (top (get-item-by-id "t1"))) ;an abritrary topic - + (let ((occ-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "occurrence")))) + (top (get-item-by-id "t1")) ;an abritrary topic + (rev-1 *TM-REVISION*)) (loop for occ-elem in occ-elems do - (is (typep (from-occurrence-elem occ-elem top revision) - 'OccurrenceC))) + (is (typep (from-occurrence-elem occ-elem top rev-1) + 'OccurrenceC))) (is (= 1 (length (elephant:get-instances-by-value - 'ItemIdentifierC - 'uri - "http://psi.egovpt.org/itemIdentifiers#t100_o1")))) + 'ItemIdentifierC + 'uri + "http://psi.egovpt.org/itemIdentifiers#t100_o1")))) (let ((t100-occ1 (identified-construct @@ -166,9 +164,9 @@ 'ItemIdentifierC 'uri "http://psi.egovpt.org/itemIdentifiers#t100_o2")))) - (is (= 1 (length (item-identifiers t100-occ1))));just to double-check + (is (= 1 (length (item-identifiers t100-occ1 :revision rev-1)))) ;just to double-check (is (string= - (uri (first (item-identifiers t100-occ1))) + (uri (first (item-identifiers t100-occ1 :revision rev-1))) "http://psi.egovpt.org/itemIdentifiers#t100_o1")) (is (string= (charvalue t100-occ1) "http://www.budabe.de/")) (is (string= (datatype t100-occ1) "http://www.w3.org/2001/XMLSchema#anyURI")) @@ -179,40 +177,39 @@ "Test the merge-topic-elem function of the importer" (with-fixture initialized-test-db() - (let - ((topic-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic"))))) - + (let ((topic-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic")))) + (rev-1 *TM-REVISION*)) (loop for topic-elem in topic-elems do (is (typep - (merge-topic-elem topic-elem revision :tm fixtures::tm) + (merge-topic-elem topic-elem rev-1 :tm fixtures::tm) 'TopicC))) (let ((top-t1 (merge-topic-elem (first topic-elems) - revision :tm fixtures::tm)) + rev-1 :tm fixtures::tm)) (top-t57 (get-item-by-id "t57")) (top-t101 (get-item-by-id "t101")) (top-t301 (get-item-by-id "t301")) (top-t301a (get-item-by-id "t301a")) ;one of the core PSIs (top-sup-sub (get-item-by-id "supertype-subtype" :xtm-id "core.xtm"))) - (is (= (internal-id top-t301) - (internal-id top-t301a))) - (is (= (length (occurrences top-t1)) 0)) - (is (= (length (occurrences top-t101)) 4)) - (is (= (length (names top-t57)) 1)) - (is (string= (uri (first (item-identifiers top-t57))) + (is (= (elephant::oid top-t301) (elephant::oid top-t301a))) + (is-true top-t301a) + (is (= (length (occurrences top-t1 :revision rev-1)) 0)) + (is (= (length (occurrences top-t101 :revision rev-1)) 4)) + (is (= (length (names top-t57 :revision rev-1)) 1)) + (is (string= (uri (first (item-identifiers top-t57 :revision rev-1))) "http://psi.egovpt.org/itemIdentifiers#t57")) - (is (= 2 (length (names top-t101)))) - (is (= 2 (length (names top-t301)))) ;after merge - (is-true (item-identifiers (first (names top-t301)))) ;after merge - (is (= 2 (length (psis top-t301)))) ;after merge - (is (= 3 (length (occurrences top-t301)))) ;after merge + (is (= 2 (length (names top-t101 :revision rev-1)))) + (is (= 2 (length (names top-t301 :revision rev-1)))) ;after merge + (is-true (item-identifiers (first (names top-t301 :revision rev-1)) + :revision rev-1)) ;after merge + (is (= 2 (length (psis top-t301 :revision rev-1)))) ;after merge + (is (= 3 (length (occurrences top-t301 :revision rev-1)))) ;after merge (is (string= "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype" - (uri (first (psis top-sup-sub))))))) - + (uri (first (psis top-sup-sub :revision rev-1))))))) ;34 topics in 35 topic elements in notificationbase.xtm and 13 ;core topics (is (= (+ 34 13) (length (elephant:get-instances-by-class 'TopicC)))))) @@ -226,51 +223,49 @@ (xpath-select-location-path *XTM-TM* '((*xtm2.0-ns* "association") - (*xtm2.0-ns* "role"))))) + (*xtm2.0-ns* "role")))) + (rev-1 *TM-REVISION*)) (loop for role-elem in role-elems do (is (typep (from-role-elem role-elem revision) 'list))) (let ((12th-role (from-role-elem (nth 11 role-elems) revision))) (is (string= "t101" - (topicid - (getf 12th-role :player) *TEST-TM*))) + (topic-id + (getf 12th-role :player) rev-1 *TEST-TM*))) (is (string= "t62" - (topicid - (getf 12th-role :instance-of) *TEST-TM*))))))) + (topic-id + (getf 12th-role :instance-of) rev-1 *TEST-TM*))))))) + (test test-from-association-elem "Test the form-association-elem function of the importer" (with-fixture initialized-test-db() - (let - ((assoc-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "association"))))) + (let ((assoc-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "association")))) + (rev-1 *TM-REVISION*)) (loop for assoc-elem in assoc-elems do (is - (typep (from-association-elem assoc-elem revision :tm fixtures::tm) + (typep (from-association-elem assoc-elem rev-1 :tm fixtures::tm) 'AssociationC))) - ;(trace datamodel:item-identifiers datamodel::filter-slot-value-by-revision) - (let - ((6th-assoc - (sixth (elephant:get-instances-by-class 'AssociationC))) - (last-assoc - (seventh (elephant:get-instances-by-class 'AssociationC)))) - (is (= 2 (length (roles last-assoc)))) - (is (= 1 (length (item-identifiers last-assoc)))) + (let ((6th-assoc + (sixth (elephant:get-instances-by-class 'AssociationC))) + (last-assoc + (seventh (elephant:get-instances-by-class 'AssociationC)))) + (is (= 2 (length (roles last-assoc :revision rev-1)))) + (is (= 1 (length (item-identifiers last-assoc :revision rev-1)))) (is (string= "t300" - (topicid (player (first (roles 6th-assoc))) *TEST-TM*))) + (topic-id (player (first (roles 6th-assoc :revision rev-1)) + :revision rev-1) rev-1 *TEST-TM*))) (is (string= "t63" - (topicid (instance-of (first (roles 6th-assoc))) - *TEST-TM*))) + (topic-id (instance-of (first (roles 6th-assoc :revision rev-1)) + :revision rev-1) rev-1 *TEST-TM*))) (is (string= "t301" - (topicid (player (first (roles last-assoc))) - *TEST-TM*)))) - ;(untrace datamodel:item-identifiers datamodel::filter-slot-value-by-revision)) - ) - ;(map 'list (lambda (a) (format t "~a" (exporter:to-string a))) (elephant:get-instances-by-class 'AssociationC)) + (topic-id (player (first (roles last-assoc :revision rev-1)) + :revision rev-1) rev-1 *TEST-TM*))))) (is (= 7 (length (elephant:get-instances-by-class 'AssociationC)))))) @@ -280,64 +275,60 @@ (declare (optimize (debug 3))) (with-fixture initialized-test-db() - (let - ((topic-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic"))))) + (let ((topic-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic")))) + (rev-1 *TM-REVISION*)) (loop for topic-elem in topic-elems do - (let - ( - ;this already implicitly creates the instanceOf - ;associations as needed - (topic (merge-topic-elem topic-elem revision :tm fixtures::tm))) - ;(format t "instanceof-topicrefs: ~a~&" instanceof-topicrefs) - (dolist (io-role - (elephant:get-instances-by-value - 'RoleC - 'player topic)) - (let - ((io-assoc (parent io-role))) - ;(format t "(io-topicref: ~a, topic: ~a)~&" io-topicref topic) - (is - (typep io-assoc - 'AssociationC)) - (is (string= (topicid topic) - (topicid (player (second (roles io-assoc)))))))))) - - (let* - ((t101-top (get-item-by-id "t101")) + (let (;this already implicitly creates the instanceOf + ;associations as needed + (topic (merge-topic-elem topic-elem rev-1 :tm fixtures::tm))) + (dolist (io-role (map 'list #'d::parent-construct + (d::slot-p topic 'd::player-in-roles))) + (let ((io-assoc (parent io-role :revision rev-1))) + (is (typep io-assoc 'AssociationC)) + (is (string= (topic-id topic rev-1) + (topic-id (player (second + (roles io-assoc :revision rev-1)) + :revision rev-1) rev-1))))))) + (let* ((t101-top (get-item-by-id "t101" :revision rev-1)) ;get all the roles t101 is involved in - (roles-101 (elephant:get-instances-by-value 'RoleC 'player t101-top)) + (roles-101 (map 'list #'d::parent-construct + (d::slot-p t101-top 'd::player-in-roles))) ;and filter those whose roletype is "instance" ;(returning, of course, a list) - ;TODO: what we'd really need ;is a filter that works ;directly on the indices ;rather than instantiating ;many unnecessary role objects - (role-101 (remove-if-not - (lambda (role) - (string= (uri (first (psis (instance-of role)))) - "http://psi.topicmaps.org/iso13250/model/instance")) roles-101))) + (role-101 (remove-if-not + (lambda (role) + (string= (uri (first (psis + (instance-of role :revision rev-1) + :revision rev-1))) + "http://psi.topicmaps.org/iso13250/model/instance")) + roles-101))) ;Topic t101 (= Topic Maps 2002 ;standard) is subclass of ;topic t3a (semantic standard) - (is-true t101-top) (is (= 1 (length role-101))) - ;(is (= 1 (length (d::versions role-101)))) (is (string= "t3a" - (topicid (player (first (roles (parent (first role-101))))) *TEST-TM*))) + (topic-id (player (first (roles (parent (first role-101)) + :revision rev-1)) + :revision rev-1) + rev-1 *TEST-TM*))) (is (string= "type-instance" - (topicid (instance-of - (parent (first role-101))) "core.xtm"))) - )))) + (topic-id (instance-of + (parent (first role-101) :revision rev-1)) + rev-1 "core.xtm"))))))) + (test test-error-detection "Test for the detection of common errors such as dangling -references, duplicate PSIs or item identifiers" + references, duplicate PSIs or item identifiers" (declare (optimize (debug 3))) (with-fixture bare-test-db() (signals missing-reference-error @@ -356,7 +347,7 @@ (importer xtm-dom :xtm-id "missing-reference-error-2" :tm-id "http://www.isidor.us/unittests/baretests")))) (with-fixture bare-test-db() - (signals duplicate-identifier-error + (signals not-mergable-error (let ((xtm-dom (dom:document-element @@ -373,49 +364,52 @@ (xml-importer:setup-repository *t100.xtm* dir :xtm-id *TEST-TM* :tm-id "http://www.isidor.us/unittests/topic-t100") (elephant:open-store (xml-importer:get-store-spec dir)) - (is (= 25 (length (elephant:get-instances-by-class 'TopicC)))) ;; are all topics in the db +std topics - (is-true (get-item-by-id "t100")) ;; main topic - (is-true (get-item-by-id "t3a")) ;; instanceOf - (is-true (get-item-by-id "t50a")) ;; scope - (is-true (get-item-by-id "t51")) ;; occurrence/type - (is-true (get-item-by-id "t52")) ;; occurrence/resourceRef - (is-true (get-item-by-id "t53")) ;; occurrence/type - (is-true (get-item-by-id "t54")) ;; occurrence/type - (is-true (get-item-by-id "t55")) ;; occurrence/type - (let ((t100 (get-item-by-id "t100"))) + (is-true (get-item-by-id "t100" :revision 0)) ;; main topic + (is-true (get-item-by-id "t3a" :revision 0)) ;; instanceOf + (is-true (get-item-by-id "t50a" :revision 0)) ;; scope + (is-true (get-item-by-id "t51" :revision 0)) ;; occurrence/type + (is-true (get-item-by-id "t52" :revision 0)) ;; occurrence/resourceRef + (is-true (get-item-by-id "t53" :revision 0)) ;; occurrence/type + (is-true (get-item-by-id "t54" :revision 0)) ;; occurrence/type + (is-true (get-item-by-id "t55" :revision 0)) ;; occurrence/type + (let ((t100 (get-item-by-id "t100" :revision 0))) ;; checks instanceOf - (is (= 1 (length (player-in-roles t100)))) - (let* - ((role-t100 (first (player-in-roles t100))) - (assoc (parent role-t100)) - (role-t3a (first (roles assoc)))) - (is (= 1 (length (psis (instance-of role-t100))))) - (is (string= (uri (first (psis (instance-of role-t100)))) "http://psi.topicmaps.org/iso13250/model/instance")) - (is (= 1 (length (psis (instance-of role-t3a))))) - (is (string= (uri (first (psis (instance-of role-t3a)))) "http://psi.topicmaps.org/iso13250/model/type"))) - + (is (= 1 (length (player-in-roles t100 :revision 0)))) + (let* ((role-t100 (first (player-in-roles t100 :revision 0))) + (assoc (parent role-t100 :revision 0)) + (role-t3a (first (roles assoc :revision 0)))) + (is (= 1 (length (psis (instance-of role-t100 :revision 0) :revision 0)))) + (is (string= (uri (first (psis (instance-of role-t100 :revision 0) + :revision 0))) + "http://psi.topicmaps.org/iso13250/model/instance")) + (is (= 1 (length (psis (instance-of role-t3a :revision 0) :revision 0)))) + (is (string= (uri (first (psis (instance-of role-t3a :revision 0) + :revision 0))) + "http://psi.topicmaps.org/iso13250/model/type"))) ;; checks subjectIdentifier - (is (= 1 (length (psis t100)))) + (is (= 1 (length (psis t100 :revision 0)))) (is (string= "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…" - (uri (first (psis t100))))) - (is (equal (identified-construct (first (psis t100))) t100)) ;;other association part - + (uri (first (psis t100 :revision 0))))) + (is (equal (identified-construct (first (psis t100 :revision 0)) + :revision 0) t100)) ;;other association part ;; checks names - (is (= 2 (length (names t100)))) - (loop for item in (names t100) + (is (= 2 (length (names t100 :revision 0)))) + (loop for item in (names t100 :revision 0) do (is (or (string= (charvalue item) "ISO 19115") (and (string= (charvalue item) "ISO 19115:2003 Geographic Information - Metadata") - (= (length (themes item)) 1) - (= (length (psis (first (themes item))))) - (string= (uri (first (psis (first (themes item))))) "http://psi.egovpt.org/types/long-name"))))) - (is-true (used-as-theme (get-item-by-id "t50a"))) ;checks the other part of the association -> fails - + (= (length (themes item :revision 0)) 1) + (= (length (psis (first (themes item :revision 0)) + :revision 0))) + (string= (uri (first (psis (first (themes item :revision 0)) + :revision 0))) + "http://psi.egovpt.org/types/long-name"))))) + (is-true (used-as-theme (get-item-by-id "t50a" :revision 0) + :revision 0)) ;checks the other part of the association -> fails ;; checks occurrences + (setf *TM-REVISION* 0) (is (= 4 (length (occurrences (get-item-by-id "t100"))))) (loop for item in (occurrences t100) - ;;(elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item) - ;; fails with all 4 occurrences because the association is missing in the topics when (elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item) do (progn (is (string= (charvalue item) "#t52")) @@ -433,12 +427,7 @@ when (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item) do (progn (is (string= (charvalue item) "http://www.editeur.org/standards/ISO19115.pdf")) - (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links"))) - when (and (not (elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item)) - (not (elephant:associatedp (get-item-by-id "t53") 'datamodel::used-as-type item)) - (not (elephant:associatedp (get-item-by-id "t54") 'datamodel::used-as-type item)) - (not (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item))) - do (is-true nil)))))) + (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links")))))))) (test test-setup-repository-xtm1.0 @@ -450,31 +439,47 @@ *sample_objects.xtm* dir :tm-id "http://www.isidor.us/unittests/xtm1.0-tests" :xtm-id *TEST-TM* :xtm-format '1.0) - + (setf *TM-REVISION* 0) (elephant:open-store (xml-importer:get-store-spec dir)) - (is (= 36 (length (elephant:get-instances-by-class 'TopicC)))) ;13 + (23 core topics) - (is (= 13 (length (elephant:get-instances-by-class 'AssociationC)))) ;2 + (11 instanceOf) - (is (= 26 (length (elephant:get-instances-by-class 'RoleC)))) ;4 + (22 instanceOf-associations) - (is (= 36 (length (elephant:get-instances-by-class 'PersistentIdC)))) ;23 + (13 core topics) + ;13 + (23 core topics) + (is (= 36 (length (elephant:get-instances-by-class 'TopicC)))) + ;2 + (11 instanceOf) + (is (= 13 (length (elephant:get-instances-by-class 'AssociationC)))) + ;4 + (22 instanceOf-associations) + (is (= 26 (length (elephant:get-instances-by-class 'RoleC)))) + ;23 + (13 core topics) + (is (= 36 (length (elephant:get-instances-by-class 'PersistentIdC)))) (is (= 0 (length (elephant:get-instances-by-class 'SubjectLocatorC)))) - (is (= 2 (length (elephant:get-instances-by-class 'OccurrenceC)))) ;2 + (0 core topics) - (is (= 18 (length (elephant:get-instances-by-class 'NameC)))) ;18 + (0 core topics) + ;2 + (0 core topics) + (is (= 2 (length (elephant:get-instances-by-class 'OccurrenceC)))) + ;18 + (0 core topics) + (is (= 18 (length (elephant:get-instances-by-class 'NameC)))) (let ((t-2526 (get-item-by-id "t-2526")) (t-2656 (get-item-by-id "t-2656")) (assoc (first (used-as-type (get-item-by-id "t89671052499"))))) (is (= (length (player-in-roles t-2526)) 1)) (is (= (length (psis t-2526)) 1)) - (is (string= (uri (first (psis t-2526))) "http://psi.egovpt.org/types/serviceUsesTechnology")) + (is (string= (uri (first (psis t-2526))) + "http://psi.egovpt.org/types/serviceUsesTechnology")) (is (= (length (names t-2526)) 3)) - (is (or (string= (charvalue (first (names t-2526))) "service uses technology") - (string= (charvalue (second (names t-2526))) "service uses technology") - (string= (charvalue (third (names t-2526))) "service uses technology"))) - (is (or (string= (charvalue (first (names t-2526))) "uses technology") - (string= (charvalue (second (names t-2526))) "uses technology") - (string= (charvalue (third (names t-2526))) "uses technology"))) - (is (or (string= (charvalue (first (names t-2526))) "used by service") - (string= (charvalue (second (names t-2526))) "used by service") - (string= (charvalue (third (names t-2526))) "used by service"))) + (is (or (string= (charvalue (first (names t-2526))) + "service uses technology") + (string= (charvalue (second (names t-2526))) + "service uses technology") + (string= (charvalue (third (names t-2526))) + "service uses technology"))) + (is (or (string= (charvalue (first (names t-2526))) + "uses technology") + (string= (charvalue (second (names t-2526))) + "uses technology") + (string= (charvalue (third (names t-2526))) + "uses technology"))) + (is (or (string= (charvalue (first (names t-2526))) + "used by service") + (string= (charvalue (second (names t-2526))) + "used by service") + (string= (charvalue (third (names t-2526))) + "used by service"))) (loop for name in (names t-2526) when (string= (charvalue name) "uses technology") do (is (= (length (themes name)) 1)) @@ -484,15 +489,18 @@ (is (eq (first (themes name)) (get-item-by-id "t-2593")))) (is (= (length (player-in-roles t-2656)) 2)) ;association + instanceOf (is (= (length (psis t-2656)) 1)) - (is (string= (uri (first (psis t-2656))) "http://psi.egovpt.org/types/DO-NOT-SIGNAL-no-identifier-error")) + (is (string= (uri (first (psis t-2656))) + "http://psi.egovpt.org/types/DO-NOT-SIGNAL-no-identifier-error")) (is (= (length (occurrences t-2656)) 2)) (loop for occ in (occurrences t-2656) when (eq (instance-of occ) (get-item-by-id "t-2625")) do (is (string= (charvalue occ) "0")) - (is (string= (datatype occ) "http://www.w3.org/2001/XMLSchema#string")) + (is (string= (datatype occ) + "http://www.w3.org/2001/XMLSchema#string")) when (eq (instance-of occ) (get-item-by-id "t-2626")) do (is (string= (charvalue occ) "unbounded")) - (is (string= (datatype occ) "http://www.w3.org/2001/XMLSchema#string")) + (is (string= (datatype occ) + "http://www.w3.org/2001/XMLSchema#string")) when (not (or (eq (instance-of occ) (get-item-by-id "t-2625")) (eq (instance-of occ) (get-item-by-id "t-2626")))) do (is-true (format t "bad occurrence found in t-2526"))) @@ -504,8 +512,8 @@ do (is (eq (instance-of role) (get-item-by-id "narrower-term"))) when (not (or (eq (player role) (get-item-by-id "all-subjects")) (eq (player role) (get-item-by-id "t1106723946")))) - do (is-true (format t "bad role found in association: ~A" (topic-identifiers (player role))))))))) - + do (is-true (format t "bad role found in association: ~A" + (topic-identifiers (player role))))))))) (test test-variants @@ -513,8 +521,9 @@ ((dir "data_base")) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository - *notificationbase.xtm* dir :xtm-id *TEST-TM*) - + *notificationbase.xtm* dir :xtm-id *TEST-TM* + :tm-id "http://isidorus.org/test-tm") + (setf *TM-REVISION* 0) (elephant:open-store (xml-importer:get-store-spec dir)) (let ((variants (elephant:get-instances-by-class 'VariantC))) (is (= (length variants) 4)) @@ -523,7 +532,7 @@ (d-type (datatype variant)) (string-type "http://www.w3.org/2001/XMLSchema#string") (itemIdentities (map 'list #'uri (item-identifiers variant))) - (parent-name-value (charvalue (name variant))) + (parent-name-value (charvalue (parent variant))) (scopes (map 'list #'uri (map 'list #'(lambda(x) (first (psis x))) ;these topics have only one psi @@ -534,8 +543,8 @@ (cond ((string= resourceData "Long-Version") (is (string= parent-name-value "long version of a name")) - (is (= (length (variants (name variant))) 1)) - (is (eql variant (first (variants (name variant))))) + (is (= (length (variants (parent variant))) 1)) + (is (eql variant (first (variants (parent variant))))) (check-for-duplicate-identifiers variant) (is-false itemIdentities) (is (= (length scopes) 1)) @@ -543,26 +552,28 @@ (is (string= d-type string-type))) ((string= resourceData "Geographic Information - Metadata") (is (string= parent-name-value "ISO 19115")) - (is (= (length (variants (name variant))) 2)) - (is (or (eql variant (first (variants (name variant)))) - (eql variant (second (variants (name variant)))))) + (is (= (length (variants (parent variant))) 2)) + (is (or (eql variant (first (variants (parent variant)))) + (eql variant (second (variants (parent variant)))))) (check-for-duplicate-identifiers variant) (is (= (length scopes) 1)) (is (string= (first scopes) display-psi)) (is (= (length itemIdentities) 1)) - (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1")) + (is (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1")) (is (string= d-type string-type))) ((string= resourceData "ISO-19115") (check-for-duplicate-identifiers variant) (is (= (length itemIdentities) 1)) - (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2")) + (is (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2")) (is (= (length scopes) 1)) (is (string= (first scopes) sort-psi)) (is (string= d-type string-type))) ((string= resourceData "ISO/IEC-13250:2002") (is (string= parent-name-value "ISO/IEC 13250:2002: Topic Maps")) - (is (= (length (variants (name variant))) 1)) - (is (eql variant (first (variants (name variant))))) + (is (= (length (variants (parent variant))) 1)) + (is (eql variant (first (variants (parent variant))))) (check-for-duplicate-identifiers variant) (check-for-duplicate-identifiers variant) (is (= (length scopes) 2)) @@ -571,10 +582,14 @@ (is (or (string= (second scopes) t50a-psi) (string= (second scopes) sort-psi))) (is (= (length itemIdentities) 2)) - (is (or (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") - (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) - (is (or (string= (second itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") - (string= (second itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) + (is (or (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") + (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) + (is (or (string= (second itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") + (string= (second itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) (is (string= d-type string-type))) (t (is-true (format t "found bad resourceData in variant object: ~A~%" resourceData)))))))))) @@ -583,12 +598,11 @@ (test test-variants-xtm1.0 "tests the importer-xtm1.0 -> variants" - (let - ((dir "data_base")) + (let ((dir "data_base")) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository - *sample_objects.xtm* dir :xtm-id *TEST-TM* :xtm-format '1.0) - + *sample_objects.xtm* dir :xtm-id *TEST-TM* :xtm-format '1.0 + :tm-id "http://isidorus.org/test-tm") (elephant:open-store (xml-importer:get-store-spec dir)) (is (= (length (elephant:get-instances-by-class 'VariantC)) 5)) (let ((t-2526 (get-item-by-id "t-2526"))) @@ -596,48 +610,59 @@ do (let ((baseNameString (charvalue baseName)) (name-variants (variants baseName))) (loop for variant in name-variants - do (is (string= (datatype variant) "http://www.w3.org/2001/XMLSchema#string"))) + do (is (string= (datatype variant) + "http://www.w3.org/2001/XMLSchema#string"))) (cond ((string= baseNameString "service uses technology") (is (= (length name-variants) 2)) (loop for variant in name-variants - do (is (eql baseName (name variant))) + do (is (eql baseName (parent variant))) (let ((variantName (charvalue variant))) (cond ((string= variantName "service-uses-technology") (is (= (length (themes variant)) 1)) - (is (eql (first (themes variant)) (get-item-by-id "sort")))) + (is (eql (first (themes variant)) + (get-item-by-id "sort")))) ((string= variantName "service uses technology") (is (= (length (themes variant)) 1)) - (is (eql (first (themes variant)) (get-item-by-id "display")))) + (is (eql (first (themes variant)) + (get-item-by-id "display")))) (t (is-true (format t "basevariantName found in t-2526: ~A~%" variantName))))))) ((string= baseNameString "uses technology") (is (= (length name-variants) 2)) (loop for variant in name-variants - do (is (eql baseName (name variant))) + do (is (eql baseName (parent variant))) (let ((variantName (charvalue variant))) (cond ((string= variantName "uses technology") (is (= (length (themes variant)) 2)) - (is-true (find (get-item-by-id "t-2555") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "display") (themes variant) :test #'eql))) + (is-true (find (get-item-by-id "t-2555") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "display") + (themes variant) :test #'eql))) ((string= variantName "uses-technology") (is (= (length (themes variant)) 3)) - (is-true (find (get-item-by-id "t-2555") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "display") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "sort") (themes variant) :test #'eql))) + (is-true (find (get-item-by-id "t-2555") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "display") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "sort") + (themes variant) :test #'eql))) (t (is-true (format t "bad variantName found in t-2526: ~A~%" variantName))))))) ((string= baseNameString "used by service") (is (= (length name-variants) 1)) (loop for variant in name-variants - do (is (eql baseName (name variant))) + do (is (eql baseName (parent variant))) (is (string= (charvalue variant) "used-by-service")) (is (= (length (themes variant)) 3)) - (is-true (find (get-item-by-id "t-2593") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "display") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "sort") (themes variant) :test #'eql)))) + (is-true (find (get-item-by-id "t-2593") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "display") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "sort") + (themes variant) :test #'eql)))) (t (is-true (format t "bad baseNameString found in names of t-2526: ~A~%" baseNameString)))))))))) @@ -654,7 +679,7 @@ '("http://www.isidor.us/unittests/testtm" "http://www.topicmaps.org/xtm/1.0/core.xtm") (mapcan (lambda (tm) - (mapcar #'uri (item-identifiers tm))) + (mapcar #'uri (item-identifiers tm :revision 0))) tms) :test #'string=))))) Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Sun Oct 10 05:41:19 2010 @@ -59,96 +59,112 @@ (test test-to-json-string-topics - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" - :xtm-id *TEST-TM*) - + :xtm-id *TEST-TM*) (elephant:open-store (xml-importer:get-store-spec dir)) - (let ((t50a (get-item-by-id "t50a"))) - (let ((t50a-string (to-json-string t50a)) + (let ((t50a (get-item-by-id "t50a" :xtm-id *TEST-TM* :revision rev-0))) + (let ((t50a-string (to-json-string t50a :revision 0)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" ))) + (concatenate 'string "{\"id\":\"" (topic-id t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" ))) (is (string= t50a-string json-string))) - (let ((t8 (get-item-by-id "t8"))) - (let ((t8-string (to-json-string t8)) + (let ((t8 (get-item-by-id "t8" :revision rev-0 :xtm-id *TEST-TM*))) + (let ((t8-string (to-json-string t8 :revision rev-0 :xtm-id *TEST-TM*)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}"))) + (concatenate 'string "{\"id\":\"" (topic-id t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}"))) (is (string= t8-string json-string)))) - (let ((t-topic (get-item-by-id "topic" :xtm-id "core.xtm"))) - (let ((t-topic-string (to-json-string t-topic)) + (let ((t-topic (get-item-by-id "topic" :xtm-id "core.xtm" :revision rev-0))) + (let ((t-topic-string (to-json-string t-topic :xtm-id "core.xtm" + :revision rev-0)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}"))) + (concatenate 'string "{\"id\":\"" (topic-id t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}"))) (is (string= t-topic-string json-string)))) - (let ((t301 (get-item-by-id "t301"))) - (let ((t301-string (to-json-string t301)) + (let ((t301 (get-item-by-id "t301" :xtm-id *TEST-TM* :revision rev-0))) + (let ((t301-string (to-json-string t301 :xtm-id *TEST-TM* :revision rev-0)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}"))) + (concatenate 'string "{\"id\":\"" (topic-id t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}"))) (is (string= t301-string json-string)))) - (let ((t100 (get-item-by-id "t100"))) - (let ((t100-string (to-json-string t100)) + (let ((t100 (get-item-by-id "t100" :revision rev-0 :xtm-id *TEST-TM*))) + (let ((t100-string (to-json-string t100 :revision rev-0 :xtm-id *TEST-TM*)) (json-string - (concatenate 'string "{\"id\":\"" (topicid t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}"))) + (concatenate 'string "{\"id\":\"" (topic-id t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}"))) (is (string= t100-string json-string)))))))) (test test-to-json-string-associations - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - (elephant:open-store (xml-importer:get-store-spec dir)) - (let ((t57 (get-item-by-id "t57")) - (t59 (get-item-by-id "t59")) - (t202 (get-item-by-id "t202")) - (t58 (get-item-by-id "t58")) - (t203 (get-item-by-id "t203")) - (t64 (get-item-by-id "t64")) - (t62 (get-item-by-id "t62"))) + (let ((t57 (get-item-by-id "t57" :revision rev-0 :xtm-id *TEST-TM*)) + (t59 (get-item-by-id "t59" :revision rev-0 :xtm-id *TEST-TM*)) + (t202 (get-item-by-id "t202" :revision rev-0 :xtm-id *TEST-TM*)) + (t58 (get-item-by-id "t58" :revision rev-0 :xtm-id *TEST-TM*)) + (t203 (get-item-by-id "t203" :revision rev-0 :xtm-id *TEST-TM*)) + (t64 (get-item-by-id "t64" :revision rev-0 :xtm-id *TEST-TM*)) + (t62 (get-item-by-id "t62" :revision rev-0 :xtm-id *TEST-TM*))) (let ((association-1 - (loop for association in (elephant:get-instances-by-class 'AssociationC) - when (and (eq t57 (instance-of association)) - (eq t59 (instance-of (first (roles association)))) - (eq t202 (player (first (roles association)))) - (eq t58 (instance-of (second (roles association)))) - (eq t203 (player (second (roles association))))) + (loop for association in + (elephant:get-instances-by-class 'AssociationC) + when (and (eq t57 (instance-of association :revision rev-0)) + (eq t59 (instance-of + (first (roles association :revision rev-0)) + :revision rev-0)) + (eq t202 (player + (first (roles association :revision rev-0)) + :revision rev-0)) + (eq t58 (instance-of + (second (roles association :revision rev-0)) + :revision rev-0)) + (eq t203 (player + (second (roles association :revision rev-0)) + :revision rev-0))) return association)) (association-7 (identified-construct - (elephant:get-instance-by-value 'ItemIdentifierC 'uri - "http://psi.egovpt.org/itemIdentifiers#assoc_7")))) - (let ((association-1-string (to-json-string association-1)) + (elephant:get-instance-by-value + 'ItemIdentifierC 'uri + "http://psi.egovpt.org/itemIdentifiers#assoc_7") + :revision rev-0))) + (let ((association-1-string + (to-json-string association-1 :revision rev-0 :xtm-id *TEST-TM*)) (json-string (concatenate 'string "{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/isNarrowerSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/broaderSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Data\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/narrowerSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]}"))) (is (string= association-1-string json-string))) - (let ((association-7-string (to-json-string association-7)) + (let ((association-7-string + (to-json-string association-7 :revision rev-0 :xtm-id *TEST-TM*)) (json-string (concatenate 'string "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}"))) (is (string= association-7-string json-string))) - (elephant:remove-association association-7 'roles (first (roles association-7))) - (elephant:remove-association association-7 'roles (first (roles association-7))) - (elephant:remove-association association-7 'instance-of t64) - (elephant:add-association association-7 'themes t64) - (elephant:add-association association-7 'themes t62) - (let ((association-7-string (to-json-string association-7)) + (let ((rev-1 (get-revision))) + (delete-role association-7 (first (roles association-7 :revision 0)) + :revision rev-1) + (delete-role association-7 (first (roles association-7 :revision 0)) + :revision rev-1) + (delete-type association-7 (instance-of association-7 :revision 0) + :revision rev-1) + (add-theme association-7 t62 :revision rev-1) + (add-theme association-7 t64 :revision rev-1)) + (let ((association-7-string + (to-json-string association-7 :revision rev-0 :xtm-id *TEST-TM*)) (json-string (concatenate 'string "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]],\"roles\":null}"))) (is (string= association-7-string json-string)))))))) (test test-to-json-string-fragments - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - (elephant:open-store (xml-importer:get-store-spec dir)) (let ((frag-t100 (create-latest-fragment-of-topic @@ -156,34 +172,40 @@ (frag-topic (create-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#topic"))) (let ((frag-t100-string - (concatenate 'string "{\"topic\":{\"id\":\"" (d:topicid (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}")) + (concatenate 'string "{\"topic\":{\"id\":\"" (d:topic-id (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}")) (frag-topic-string - (concatenate 'string "{\"topic\":{\"id\":\"" (topicid (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}"))) - (is (string= frag-t100-string (to-json-string frag-t100))) - (is (string= frag-topic-string (to-json-string frag-topic)))))))) + (concatenate 'string "{\"topic\":{\"id\":\"" (topic-id (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}"))) + (is (string= + frag-t100-string + (to-json-string frag-t100 :xtm-id *TEST-TM* :revision rev-0))) + (is (string= + frag-topic-string + (to-json-string frag-topic :xtm-id *TEST-TM* :revision rev-0)))))))) (test test-get-fragment-values-from-json-list-general - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) - (to-json-string fragment-obj)))) + (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*)))) (let ((fragment-list (json-importer::get-fragment-values-from-json-list (json:decode-json-from-string json-fragment)))) (let ((topic (getf fragment-list :topic))) (is (string= (getf topic :ID) - (d:topicid - (d:identified-construct (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri - "http://psi.egovpt.org/standard/Topic+Maps+2002"))))) + (d:topic-id + (d:identified-construct + (elephant:get-instance-by-value + 'd:PersistentIdC 'd:uri + "http://psi.egovpt.org/standard/Topic+Maps+2002") + :revision rev-0)))) (is-false (getf topic :itemIdentities)) (is-false (getf topic :subjectLocators)) (is (= (length (getf topic :subjectIdentifiers)) 1)) @@ -196,18 +218,17 @@ (test test-get-fragment-values-from-json-list-names - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) - (to-json-string fragment-obj)))) + (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*)))) (let ((fragment-list (json-importer::get-fragment-values-from-json-list (json:decode-json-from-string json-fragment)))) @@ -263,18 +284,17 @@ (test test-get-fragment-values-from-json-list-occurrences - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) - (to-json-string fragment-obj)))) + (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*)))) (let ((fragment-list (json-importer::get-fragment-values-from-json-list (json:decode-json-from-string json-fragment)))) @@ -294,7 +314,7 @@ "http://psi.egovpt.org/types/standardHasStatus")) (is-false (getf occurrence-1 :scopes)) (is (string= (getf occurrence-1 :resourceRef) - (concatenate 'string "#" (d:topicid ref-topic)))) + (concatenate 'string "#" (d:topic-id ref-topic)))) (is-false (getf occurrence-1 :resourceData)) (is-false (getf occurrence-2 :itemIdentities)) (is (= (length (getf occurrence-2 :type)) 1)) @@ -326,18 +346,17 @@ (test test-get-fragment-values-from-json-list-topicStubs - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) - (to-json-string fragment-obj)))) + (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*)))) (let ((fragment-list (json-importer::get-fragment-values-from-json-list (json:decode-json-from-string json-fragment)))) @@ -357,35 +376,43 @@ subjectIdentifier)))) (is-true topic) (is-false subjectLocators) - (is (string= (d:topicid topic) id)) + (is (string= (d:topic-id topic) id)) (cond - ((string= subjectIdentifier "http://psi.egovpt.org/types/semanticstandard") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/semanticstandard") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t3a"))) - ((string= subjectIdentifier "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") + ((string= subjectIdentifier + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") (is-false itemIdentities)) - ((string= subjectIdentifier "http://psi.egovpt.org/types/long-name") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/long-name") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t50a"))) - ((string= subjectIdentifier "http://psi.egovpt.org/types/standardHasStatus") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/standardHasStatus") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t51"))) - ((string= subjectIdentifier "http://psi.egovpt.org/types/description") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/description") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t53"))) - ((string= subjectIdentifier "http://psi.egovpt.org/types/standardValidFromDate") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/standardValidFromDate") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t54"))) - ((string= subjectIdentifier "http://psi.egovpt.org/types/links") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/links") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t55"))) - ((string= subjectIdentifier "http://psi.egovpt.org/types/standardIsAboutSubject") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/standardIsAboutSubject") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t60"))) @@ -393,23 +420,29 @@ (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t61"))) - ((string= subjectIdentifier "http://psi.egovpt.org/subject/Semantic+Description") + ((string= subjectIdentifier + "http://psi.egovpt.org/subject/Semantic+Description") (is-false itemIdentities)) - ((string= subjectIdentifier "http://psi.egovpt.org/types/serviceUsesStandard") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/serviceUsesStandard") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t64"))) - ((string= subjectIdentifier "http://psi.egovpt.org/types/ServiceRoleType") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/ServiceRoleType") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t63"))) - ((string= subjectIdentifier "http://psi.egovpt.org/service/Norwegian+National+Curriculum") + ((string= subjectIdentifier + "http://psi.egovpt.org/service/Norwegian+National+Curriculum") (is-false itemIdentities)) - ((string= subjectIdentifier "http://psi.egovpt.org/types/StandardRoleType") + ((string= subjectIdentifier + "http://psi.egovpt.org/types/StandardRoleType") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t62"))) - ((string= subjectIdentifier "http://psi.egovpt.org/status/InternationalStandard") + ((string= subjectIdentifier + "http://psi.egovpt.org/status/InternationalStandard") (is (= (length itemIdentities) 1)) (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t52"))) @@ -419,18 +452,17 @@ (test test-get-fragment-values-from-json-list-associations - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) - (to-json-string fragment-obj)))) + (to-json-string fragment-obj :revision rev-0 :xtm-id *TEST-TM*)))) (let ((fragment-list (json-importer::get-fragment-values-from-json-list (json:decode-json-from-string json-fragment)))) @@ -491,12 +523,10 @@ (test test-json-importer-general-1 - (let - ((dir "data_base")) + (let ((dir "data_base")) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (is (= (length (elephant:get-instances-by-class 'TopicC)) 13)) (is (= (length (elephant:get-instances-by-class 'AssociationC)) 0)) (is (= (length (elephant:get-instances-by-class 'TopicMapC)) 1)) @@ -522,12 +552,10 @@ (test test-json-importer-general-2 - (let - ((dir "data_base")) + (let ((dir "data_base")) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (json-importer:json-to-elem *t64*) (let ((test-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) @@ -580,16 +608,14 @@ (test test-json-importer-general-3 - (let - ((dir "data_base")) + (let ((dir "data_base")) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (json-importer:json-to-elem *t64*) (json-importer:json-to-elem *t100-3*) - (is (= (length (elephant:get-instances-by-class 'TopicC)) 28)) ;13 new topics - (is (= (length (elephant:get-instances-by-class 'AssociationC)) 5)) ;4 new associations + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 28)) ;13 new topics + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 5)) ;4 new associations (is (= (length (elephant:get-instances-by-class 'TopicMapC)) 2)) (let ((core-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) @@ -609,162 +635,195 @@ (test test-json-importer-topics-1 - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (json-importer:json-to-elem *t64*) (json-importer:json-to-elem *t100-3*) (let ((topics (elephant:get-instances-by-class 'TopicC))) (loop for topic in topics - do (let ((psi (uri (first (psis topic))))) + do (let ((psi (uri (first (psis topic :revision rev-0))))) (cond ((string= psi "http://psi.egovpt.org/types/semanticstandard") ;t3a - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= (uri (first (item-identifiers topic :revision rev-0))) "http://psi.egovpt.org/itemIdentifiers#t3a"))) - ((string= psi "http://www.networkedplanet.com/psi/npcl/meta-types/association-type") ;t7 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) + ((string= psi + "http://www.networkedplanet.com/psi/npcl/meta-types/association-type") ;t7 + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= (uri (first (item-identifiers topic :revision rev-0))) "http://psi.egovpt.org/itemIdentifiers#t7"))) ((string= psi "http://psi.egovpt.org/types/standardHasStatus") ;t51 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= (uri (first (item-identifiers topic :revision rev-0))) "http://psi.egovpt.org/itemIdentifiers#t51"))) ((string= psi "http://psi.egovpt.org/types/description") ;t53 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= (uri (first (item-identifiers topic :revision rev-0))) "http://psi.egovpt.org/itemIdentifiers#t53"))) ((string= psi "http://psi.egovpt.org/types/standardValidFromDate") ;t54 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t54")))))))))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t54")))))))))) (test test-json-importer-topics-2 - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (json-importer:json-to-elem *t64*) (json-importer:json-to-elem *t100-3*) (let ((topics (elephant:get-instances-by-class 'TopicC))) (loop for topic in topics - do (let ((psi (uri (first (psis topic))))) + do (let ((psi (uri (first (psis topic :revision rev-0))))) (cond ((string= psi "http://psi.egovpt.org/types/links") ;t55 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t55"))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t55"))) ((string= psi "http://psi.egovpt.org/types/standardIsAboutSubject") ;t60 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t60"))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t60"))) ((string= psi "http://psi.egovpt.org/types/SubjectRoleType") ;t61 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t61"))) - ((string= psi "http://psi.egovpt.org/types/StandardRoleType") ;t62 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t62"))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t61"))) + ((string= psi + "http://psi.egovpt.org/types/StandardRoleType") ;t62 + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t62"))) ((string= psi "http://psi.egovpt.org/types/ServiceRoleType") ;t63 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t63"))) - ((string= psi "http://psi.egovpt.org/types/serviceUsesStandard") ;t64 - (is (= (length (names topic)) 1)) - (is (string= (charvalue (first (names topic))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t63"))) + ((string= psi + "http://psi.egovpt.org/types/serviceUsesStandard") ;t64 + (is (= (length (names topic :revision rev-0)) 1)) + (is (string= (charvalue (first (names topic :revision rev-0))) "service uses standard")) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t64")))))))))) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t64")))))))))) (test test-json-importer-topics-3 - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (json-importer:json-to-elem *t64*) (json-importer:json-to-elem *t100-3*) (let ((topics (elephant:get-instances-by-class 'TopicC))) (loop for topic in topics - do (let ((psi (uri (first (psis topic))))) + do (let ((psi (uri (first (psis topic :revision rev-0))))) (cond ((string= psi "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…") ;t100 - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t100")) - (is (= (length (names topic)) 1)) - (is (string= (charvalue (first (names topic))) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t100")) + (is (= (length (names topic :revision rev-0)) 1)) + (is (string= (charvalue (first (names topic :revision rev-0))) "ISO 19115")) - (is (= (length (item-identifiers (first (names topic)))))) - (is (string= (uri (first (item-identifiers (first (names topic))))) + (is (= (length (item-identifiers + (first (names topic :revision rev-0)) + :revision rev-0)))) + (is (string= (uri (first + (item-identifiers + (first (names topic :revision rev-0)) + :revision rev-0))) "http://psi.egovpt.org/itemIdentifiers#t100_n1")) - (is (= (length (variants (first (names topic)))) 2)) - (let ((variant-1 (first (variants (first (names topic))))) - (variant-2 (second (variants (first (names topic)))))) - (is (= (length (item-identifiers variant-1)) 1)) - (is (string= (uri (first (item-identifiers variant-1))) - "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1")) - (is (= (length (item-identifiers variant-2)) 1)) - (is (string= (uri (first (item-identifiers variant-2))) - "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2")) - (is (= (length (themes variant-1)) 1)) - (is (string= (uri (first (psis (first (themes variant-1))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm#display")) - (is (= (length (themes variant-2)) 1)) - (is (string= (uri (first (psis (first (themes variant-2))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")) + (is (= (length (variants + (first (names topic :revision rev-0)) + :revision rev-0)) 2)) + (let ((variant-1 (first + (variants + (first (names topic :revision rev-0)) + :revision rev-0))) + (variant-2 (second + (variants + (first (names topic :revision rev-0)) + :revision rev-0)))) + (is (= (length + (item-identifiers variant-1 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers variant-1 + :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1")) + (is (= (length + (item-identifiers variant-2 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers + variant-2 :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2")) + (is (= (length (themes variant-1 :revision rev-0)) 1)) + (is (string= + (uri (first (psis (first (themes variant-1 + :revision rev-0))))) + "http://www.topicmaps.org/xtm/1.0/core.xtm#display")) + (is (= (length (themes variant-2 :revision rev-0)) 1)) + (is (string= + (uri (first + (psis (first (themes variant-2 + :revision rev-0)) + :revision rev-0))) + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort")) (is (string= (charvalue variant-1) "Geographic Information - Metadata")) (is (string= (datatype variant-1) @@ -773,31 +832,39 @@ "ISO-19115")) (is (string= (datatype variant-2) "http://www.w3.org/2001/XMLSchema#string"))) - (is (= (length (occurrences topic)) 4)) - (let ((occ-1 (first (occurrences topic))) - (occ-2 (second (occurrences topic))) - (occ-3 (third (occurrences topic))) - (occ-4 (fourth (occurrences topic)))) - (is (= (length (item-identifiers occ-1)) 1)) - (is (string= (uri (first (item-identifiers occ-1))) - "http://psi.egovpt.org/itemIdentifiers#t100_o1")) - (is (= (length (item-identifiers occ-2)) 1)) - (is (string= (uri (first (item-identifiers occ-2))) - "http://psi.egovpt.org/itemIdentifiers#t100_o2")) - (is (= (length (item-identifiers occ-3)) 1)) - (is (string= (uri (first (item-identifiers occ-3))) - "http://psi.egovpt.org/itemIdentifiers#t100_o3")) - (is (= (length (item-identifiers occ-4)) 1)) - (is (string= (uri (first (item-identifiers occ-4))) - "http://psi.egovpt.org/itemIdentifiers#t100_o4")) - (is (string= (uri (first (psis (instance-of occ-1)))) - "http://psi.egovpt.org/types/standardHasStatus")) - (is (string= (uri (first (psis (instance-of occ-2)))) - "http://psi.egovpt.org/types/description")) - (is (string= (uri (first (psis (instance-of occ-3)))) - "http://psi.egovpt.org/types/standardValidFromDate")) - (is (string= (uri (first (psis (instance-of occ-4)))) - "http://psi.egovpt.org/types/links")) + (is (= (length (occurrences topic :revision rev-0)) 4)) + (let ((occ-1 (first (occurrences topic :revision rev-0))) + (occ-2 (second (occurrences topic :revision rev-0))) + (occ-3 (third (occurrences topic :revision rev-0))) + (occ-4 (fourth (occurrences topic :revision rev-0)))) + (is (= (length (item-identifiers occ-1 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers occ-1 :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t100_o1")) + (is (= (length (item-identifiers occ-2 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers occ-2 :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t100_o2")) + (is (= (length (item-identifiers occ-3 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers occ-3 :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t100_o3")) + (is (= (length (item-identifiers occ-4 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers occ-4 :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t100_o4")) + (is (string= + (uri (first (psis (instance-of occ-1 :revision rev-0)))) + "http://psi.egovpt.org/types/standardHasStatus")) + (is (string= + (uri (first (psis (instance-of occ-2 :revision rev-0)))) + "http://psi.egovpt.org/types/description")) + (is (string= + (uri (first (psis (instance-of occ-3 :revision rev-0)))) + "http://psi.egovpt.org/types/standardValidFromDate")) + (is (string= + (uri (first (psis (instance-of occ-4 :revision rev-0)))) + "http://psi.egovpt.org/types/links")) (is (string= (datatype occ-1) "http://www.w3.org/2001/XMLSchema#anyURI")) (is (string= (charvalue occ-1) @@ -817,86 +884,94 @@ (test test-json-importer-topics-4 - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (json-importer:json-to-elem *t64*) (json-importer:json-to-elem *t100-3*) (let ((topics (elephant:get-instances-by-class 'TopicC))) (loop for topic in topics - do (let ((psi (uri (first (psis topic))))) - (cond ((string= psi "http://psi.egovpt.org/subject/Semantic+Description") ;t201 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is-false (item-identifiers topic))) + do (let ((psi (uri (first (psis topic :revision rev-0))))) + (cond ((string= + psi + "http://psi.egovpt.org/subject/Semantic+Description") ;t201 + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is-false (item-identifiers topic :revision rev-0))) ((string= psi "http://psi.egovpt.org/subject/GeoData") ;t203 - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is-false (item-identifiers topic))) - ((or (string= psi "http://psi.egovpt.org/service/Google+Maps") ;t301a + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is-false (item-identifiers topic :revision rev-0))) + ((or (string= psi + "http://psi.egovpt.org/service/Google+Maps") ;t301a (string= psi "http://maps.google.com")) - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 2)) - (is (or (string= (uri (first (psis topic))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 2)) + (is (or (string= (uri (first (psis topic :revision rev-0))) "http://psi.egovpt.org/service/Google+Maps") - (string= (uri (first (psis topic))) + (string= (uri (first (psis topic :revision rev-0))) "http://maps.google.com"))) - (is (or (string= (uri (second (psis topic))) + (is (or (string= (uri (second (psis topic :revision rev-0))) "http://psi.egovpt.org/service/Google+Maps") - (string= (uri (second (psis topic))) + (string= (uri (second (psis topic :revision rev-0))) "http://maps.google.com"))) - (is-false (item-identifiers topic)))))))))) + (is-false (item-identifiers topic :revision rev-0)))))))))) (test test-json-importer-associations - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isiodurs closes the store (json-importer:json-to-elem *t64*) (json-importer:json-to-elem *t100-3*) (let ((assoc-7 (identified-construct - (elephant:get-instance-by-value 'ItemidentifierC 'uri - "http://psi.egovpt.org/itemIdentifiers#assoc_7")))) - (is (= (length (item-identifiers assoc-7)))) - (is (string= (uri (first (item-identifiers assoc-7))) + (elephant:get-instance-by-value + 'ItemidentifierC 'uri + "http://psi.egovpt.org/itemIdentifiers#assoc_7") + :revision rev-0))) + (is (= (length (item-identifiers assoc-7 :revision rev-0)))) + (is (string= (uri (first (item-identifiers assoc-7 :revision rev-0))) "http://psi.egovpt.org/itemIdentifiers#assoc_7")) - (is (= (length (roles assoc-7)) 2)) - (is (string= (uri (first (psis (instance-of assoc-7)))) + (is (= (length (roles assoc-7 :revision rev-0)) 2)) + (is (string= (uri (first (psis (instance-of assoc-7 :revision rev-0) + :revision rev-0))) "http://psi.egovpt.org/types/serviceUsesStandard")) - (let ((role-1 (first (roles assoc-7))) - (role-2 (second (roles assoc-7)))) - (is (string= (uri (first (psis (instance-of role-1)))) + (let ((role-1 (first (roles assoc-7 :revision rev-0))) + (role-2 (second (roles assoc-7 :revision rev-0)))) + (is (string= (uri (first (psis (instance-of role-1 :revision rev-0) + :revision rev-0))) "http://psi.egovpt.org/types/ServiceRoleType")) - (is (or (string= (uri (first (psis (player role-1)))) + (is (or (string= (uri (first (psis (player role-1 :revision rev-0) + :revision rev-0))) "http://psi.egovpt.org/service/Google+Maps") - (string= (uri (first (psis (player role-1)))) + (string= (uri (first (psis (player role-1 :revision rev-0) + :revision rev-0))) "http://maps.google.com"))) - (is (string= (uri (first (psis (instance-of role-2)))) + (is (string= (uri (first (psis (instance-of role-2 :revision rev-0) + :revision rev-0))) "http://psi.egovpt.org/types/StandardRoleType")) - (is (string= (uri (first (psis (player role-2)))) + (is (string= (uri (first (psis (player role-2 :revision rev-0) + :revision rev-0))) "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…"))))))) (test test-json-importer-merge-1 - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isidorus closes the store (is (= (length (elephant:get-instances-by-class 'TopicC)) 13)) (is (= (length (elephant:get-instances-by-class 'AssociationC)) 0)) (is (= (length (elephant:get-instances-by-class 'TopicMapC)) 1)) @@ -906,12 +981,12 @@ (is (= (length (elephant:get-instances-by-class 'TopicMapC)) 2)) (let ((core-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.topicmaps.org/xtm/1.0/core.xtm") return tm)) (test-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.isidor.us/unittests/testtm") return tm))) (is-true (and core-tm test-tm))) @@ -921,141 +996,194 @@ (is (= (length (elephant:get-instances-by-class 'TopicMapC)) 2)) (let ((core-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.topicmaps.org/xtm/1.0/core.xtm") return tm)) (test-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.isidor.us/unittests/testtm") return tm))) (is-true (and core-tm test-tm))) (let ((topics (elephant:get-instances-by-class 'TopicC))) (loop for topic in topics - do (let ((psi (uri (first (psis topic))))) + do (let ((psi (uri (first (psis topic :revision rev-0))))) (cond ((string= psi "http://psi.egovpt.org/types/standard") ;t3 - (is (= (length (in-topicmaps topic)) 1)) - (is (string= (uri (first (item-identifiers (first (in-topicmaps topic))))) - "http://www.isidor.us/unittests/testtm")) - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 2)) - (is (or (string= (uri (first (item-identifiers topic))) - "http://www.egovpt.org/itemIdentifiers#t3") - (string= (uri (second (item-identifiers topic))) - "http://www.egovpt.org/itemIdentifiers#t3"))) - (is (or (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t3") - (string= (uri (second (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t3")))) + (is (= (length (in-topicmaps topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers + (first (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.isidor.us/unittests/testtm")) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 2)) + (is (or (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t3") + (string= + (uri (second (item-identifiers topic :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t3"))) + (is (or (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t3") + (string= + (uri (second (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t3")))) ((string= psi "http://psi.egovpt.org/types/long-name") ;t50a - (is (= (length (in-topicmaps topic)) 1)) - (is (string= (uri (first (item-identifiers (first (in-topicmaps topic))))) + (is (= (length (in-topicmaps topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers + (first (in-topicmaps topic :revision rev-0)) + :revision rev-0))) "http://www.isidor.us/unittests/testtm")) - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 1)) - (is (string= (uri (first (item-identifiers topic))) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 1)) + (is (string= (uri (first (item-identifiers topic :revision rev-0))) "http://psi.egovpt.org/itemIdentifiers#t50a"))) ((string= psi "http://psi.egovpt.org/types/links") ;t50 - (is (= (length (in-topicmaps topic)) 1)) - (is (string= (uri (first (item-identifiers (first (in-topicmaps topic))))) - "http://www.isidor.us/unittests/testtm")) - (is-false (names topic)) - (is-false (occurrences topic)) - (is-false (locators topic)) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 2)) - (is (or (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t55") - (string= (uri (second (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t55"))) - (is (or (string= (uri (first (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t55_1") - (string= (uri (second (item-identifiers topic))) - "http://psi.egovpt.org/itemIdentifiers#t55_1"))))))))))) + (is (= (length (in-topicmaps topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers + (first (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.isidor.us/unittests/testtm")) + (is-false (names topic :revision rev-0)) + (is-false (occurrences topic :revision rev-0)) + (is-false (locators topic :revision rev-0)) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 2)) + (is (or (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t55") + (string= + (uri (second (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t55"))) + (is (or (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t55_1") + (string= + (uri (second (item-identifiers topic :revision rev-0))) + "http://psi.egovpt.org/itemIdentifiers#t55_1"))))))))))) (test test-json-importer-merge-2 - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isidorus closes the store (json-importer:json-to-elem *t100-1*) (let ((core-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.topicmaps.org/xtm/1.0/core.xtm") - return tm)) + return tm)) (test-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.isidor.us/unittests/testtm") return tm))) (is-true (and core-tm test-tm))) (json-importer:json-to-elem *t100-2*) (let ((topics (elephant:get-instances-by-class 'TopicC))) (loop for topic in topics - do (let ((psi (uri (first (psis topic))))) + do (let ((psi (uri (first (psis topic :revision rev-0))))) (cond - ((string= psi "http://psi.egovpt.org/types/standard") t) ;was already checked - ((string= psi "http://psi.egovpt.org/types/long-name") t) ;was already checked - ((string= psi "http://psi.egovpt.org/types/links") t) ;was already checked + ((string= psi "http://psi.egovpt.org/types/standard") + t) ;was already checked + ((string= psi "http://psi.egovpt.org/types/long-name") + t) ;was already checked + ((string= psi "http://psi.egovpt.org/types/links") + t) ;was already checked ((string= psi "http://psi.egovpt.org/standard/Common+Lisp") ;t100 - (is (= (length (in-topicmaps topic)) 1)) - (is (string= (uri (first (item-identifiers (first (in-topicmaps topic))))) - "http://www.isidor.us/unittests/testtm")) - (is (= (length (psis topic)) 1)) - (is (= (length (item-identifiers topic)) 2)) - (is (or (string= (uri (first (item-identifiers topic))) - "http://www.egovpt.org/itemIdentifiers#t100") - (string= (uri (second (item-identifiers topic))) - "http://www.egovpt.org/itemIdentifiers#t100"))) - (is (or (string= (uri (first (item-identifiers topic))) - "http://www.egovpt.org/itemIdentifiers#t100_new") - (string= (uri (second (item-identifiers topic))) - "http://www.egovpt.org/itemIdentifiers#t100_new"))) - (is (= (length (names topic)))) - (let ((name (first (names topic)))) - (is (= (length (item-identifiers name)) 2)) - (is (or (string= (uri (first (item-identifiers name))) - "http://www.egovpt.org/itemIdentifiers#t100_n1") - (string= (uri (second (item-identifiers name))) - "http://www.egovpt.org/itemIdentifiers#t100_n1"))) - (is (or (string= (uri (first (item-identifiers name))) - "http://www.egovpt.org/itemIdentifiers#t100_n1a") - (string= (uri (second (item-identifiers name))) - "http://www.egovpt.org/itemIdentifiers#t100_n1a"))) + (is (= (length (in-topicmaps topic :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers + (first (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.isidor.us/unittests/testtm")) + (is (= (length (psis topic :revision rev-0)) 1)) + (is (= (length (item-identifiers topic :revision rev-0)) 2)) + (is (or (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100") + (string= + (uri (second (item-identifiers topic :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100"))) + (is (or (string= + (uri (first (item-identifiers topic :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_new") + (string= + (uri (second (item-identifiers topic :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_new"))) + (is (= (length (names topic :revision rev-0)))) + (let ((name (first (names topic :revision rev-0)))) + (is (= (length (item-identifiers name :revision rev-0)) 2)) + (is (or (string= + (uri (first (item-identifiers name :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_n1") + (string= + (uri (second (item-identifiers name :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_n1"))) + (is (or (string= + (uri (first (item-identifiers name :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_n1a") + (string= + (uri (second (item-identifiers name :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_n1a"))) (is (string= (charvalue name) "Common Lisp")) - (is (= (length (variants name)) 2)) - (let ((variant-1 (first (variants name))) - (variant-2 (second (variants name)))) - (is (= (length (item-identifiers variant-1)) 1)) - (is (string= (uri (first (item-identifiers variant-1))) - "http://www.egovpt.org/itemIdentifiers#t100_n_v1")) - (is (= (length (item-identifiers variant-2)) 1)) - (is (string= (uri (first (item-identifiers variant-2))) - "http://www.egovpt.org/itemIdentifiers#t100_n_v2")) - (is (= (length (themes variant-1)) 2)) - (is (or (string= (uri (first (psis (first (themes variant-1))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") - (string= (uri (first (psis (second (themes variant-1))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm#sort"))) - (is (or (string= (uri (first (psis (first (themes variant-1))))) - "http://psi.egovpt.org/types/long-name") - (string= (uri (first (psis (second (themes variant-1))))) - "http://psi.egovpt.org/types/long-name"))) - (is (= (length (themes variant-2)) 1)) - (is (string= (uri (first (psis (first (themes variant-2))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm#display")) + (is (= (length (variants name :revision rev-0)) 2)) + (let ((variant-1 (first (variants name :revision rev-0))) + (variant-2 (second (variants name :revision rev-0)))) + (is (= (length (item-identifiers variant-1 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers variant-1 :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_n_v1")) + (is (= (length (item-identifiers variant-2 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers variant-2 :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_n_v2")) + (is (= (length (themes variant-1 :revision rev-0)) 2)) + (is (or (string= + (uri + (first + (psis + (first (themes variant-1 :revision rev-0)) + :revision rev-0))) + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") + (string= + (uri + (first + (psis (second (themes variant-1 :revision rev-0)) + :revision rev-0))) + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort"))) + (is (or (string= + (uri + (first + (psis (first (themes variant-1 :revision rev-0)) + :revision rev-0))) + "http://psi.egovpt.org/types/long-name") + (string= + (uri + (first + (psis (second (themes variant-1 :revision rev-0)) + :revision rev-0))) + "http://psi.egovpt.org/types/long-name"))) + (is (= (length (themes variant-2 :revision rev-0)) 1)) + (is (string= + (uri + (first + (psis (first (themes variant-2 :revision rev-0)) + :revision rev-0))) + "http://www.topicmaps.org/xtm/1.0/core.xtm#display")) (is (string= (datatype variant-1) "http://www.w3.org/2001/XMLSchema#string")) (is (string= (charvalue variant-1) @@ -1064,19 +1192,25 @@ "http://www.w3.org/2001/XMLSchema#string")) (is (string= (charvalue variant-2) "CL")))) - (is (= (length (occurrences topic)) 2)) - (let ((occ-1 (first (occurrences topic))) - (occ-2 (second (occurrences topic)))) - (is (= (length (item-identifiers occ-1)) 1)) - (is (string= (uri (first (item-identifiers occ-1))) - "http://www.egovpt.org/itemIdentifiers#t100_o1")) - (is (= (length (item-identifiers occ-2)) 1)) - (is (string= (uri (first (item-identifiers occ-2))) - "http://www.egovpt.org/itemIdentifiers#t100_o2")) - (is (string= (uri (first (psis (instance-of occ-1)))) - "http://psi.egovpt.org/types/links")) - (is (string= (uri (first (psis (instance-of occ-2)))) - "http://psi.egovpt.org/types/links")) + (is (= (length (occurrences topic :revision rev-0)) 2)) + (let ((occ-1 (first (occurrences topic :revision rev-0))) + (occ-2 (second (occurrences topic :revision rev-0)))) + (is (= (length (item-identifiers occ-1 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers occ-1 :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_o1")) + (is (= (length (item-identifiers occ-2 :revision rev-0)) 1)) + (is (string= + (uri (first (item-identifiers occ-2 :revision rev-0))) + "http://www.egovpt.org/itemIdentifiers#t100_o2")) + (is (string= + (uri (first (psis (instance-of occ-1 :revision rev-0) + :revision rev-0))) + "http://psi.egovpt.org/types/links")) + (is (string= + (uri (first (psis (instance-of occ-2 :revision rev-0) + :revision rev-0))) + "http://psi.egovpt.org/types/links")) (is (string= (datatype occ-1) "http://www.w3.org/2001/XMLSchema#anyURI")) (is (string= (charvalue occ-1) @@ -1086,178 +1220,277 @@ (is (string= (charvalue occ-2) "http://www.cliki.net/")))) (t - (if (or (string= psi "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") - (string= psi "http://www.topicmaps.org/xtm/1.0/core.xtm#display")) + (if (or (string= + psi + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") + (string= + psi + "http://www.topicmaps.org/xtm/1.0/core.xtm#display")) (progn - (is (= (length (in-topicmaps topic)) 2)) - (is (or (string= (uri (first (item-identifiers (first (in-topicmaps topic))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm") - (string= (uri (first (item-identifiers (second (in-topicmaps topic))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm"))) - (is (or (string= (uri (first (item-identifiers (first (in-topicmaps topic))))) - "http://www.isidor.us/unittests/testtm") - (string= (uri (first (item-identifiers (second (in-topicmaps topic))))) - "http://www.isidor.us/unittests/testtm")))) + (is (= (length (in-topicmaps topic :revision rev-0)) 2)) + (is (or (string= + (uri + (first + (item-identifiers + (first (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.topicmaps.org/xtm/1.0/core.xtm") + (string= + (uri + (first + (item-identifiers + (second (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.topicmaps.org/xtm/1.0/core.xtm"))) + (is (or (string= + (uri + (first + (item-identifiers + (first (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.isidor.us/unittests/testtm") + (string= + (uri + (first + (item-identifiers + (second (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.isidor.us/unittests/testtm")))) (progn - (is (= (length (in-topicmaps topic)) 1)) - (is (string= (uri (first (item-identifiers (first (in-topicmaps topic))))) - "http://www.topicmaps.org/xtm/1.0/core.xtm")))))))))))) + (is (= (length (in-topicmaps topic :revision rev-0)) 1)) + (is (string= + (uri + (first + (item-identifiers + (first (in-topicmaps topic :revision rev-0)) + :revision rev-0))) + "http://www.topicmaps.org/xtm/1.0/core.xtm")))))))))))) (test test-json-importer-merge-3 - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (elephant:open-store (xml-importer:get-store-spec dir)) (xml-importer:init-isidorus) - (elephant:open-store (xml-importer:get-store-spec dir)) ; init-isidorus closes the store (json-importer:json-to-elem *t100-1*) (let ((core-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.topicmaps.org/xtm/1.0/core.xtm") return tm)) (test-tm (loop for tm in (elephant:get-instances-by-class 'TopicMapC) - when (string= (uri (first (item-identifiers tm))) + when (string= (uri (first (item-identifiers tm :revision rev-0))) "http://www.isidor.us/unittests/testtm") return tm))) (is-true (and core-tm test-tm))) (json-importer:json-to-elem *t100-2*) (let ((instanceOf-assoc (first (elephant:get-instances-by-class 'AssociationC)))) - (is (string= (uri (first (psis (instance-of instanceOf-assoc)))) - constants::*type-instance-psi*)) - (is-false (d:themes instanceOf-assoc)) - (is (string= (d:uri (first (d:item-identifiers (first (d:in-topicmaps instanceOf-assoc))))) - "http://www.isidor.us/unittests/testtm")) - (is-false (d:item-identifiers instanceOf-assoc)) + (is (string= + (uri (first (psis (instance-of instanceOf-assoc :revision rev-0) + :revision rev-0))) + constants::*type-instance-psi*)) + (is-false (d:themes instanceOf-assoc :revision rev-0)) + (is (string= + (d:uri + (first + (d:item-identifiers + (first (d:in-topicmaps instanceOf-assoc :revision rev-0)) + :revision rev-0))) + "http://www.isidor.us/unittests/testtm")) + (is-false (d:item-identifiers instanceOf-assoc :revision rev-0)) (let ((super-type-role - (loop for role in (roles instanceOf-assoc) - when (string= (uri (first (psis (instance-of role)))) - constants:*type-psi*) + (loop for role in (roles instanceOf-assoc :revision rev-0) + when (string= + (uri (first (psis (instance-of role :revision rev-0) + :revision rev-0))) + constants:*type-psi*) return role)) (sub-type-role - (loop for role in (roles instanceOf-assoc) - when (string= (uri (first (psis (instance-of role)))) + (loop for role in (roles instanceOf-assoc :revision rev-0) + when (string= (uri (first (psis (instance-of role :revision rev-0) + :revision rev-0))) constants:*instance-psi*) return role))) (is-true (and super-type-role sub-type-role)) - (is (string= (uri (first (psis (player super-type-role)))) + (is (string= (uri (first (psis (player super-type-role :revision rev-0) + :revision rev-0))) "http://psi.egovpt.org/types/standard")) - (is (string= (uri (first (psis (player sub-type-role)))) + (is (string= (uri (first (psis (player sub-type-role :revision rev-0) + :revision rev-0))) "http://psi.egovpt.org/standard/Common+Lisp"))))))) (test test-get-all-topic-psis - (let - ((dir "data_base")) + (let ((dir "data_base") + (rev-0 0)) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository - *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) - + *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" + :xtm-id *TEST-TM*) (elephant:open-store (xml-importer:get-store-spec dir)) - (let ((json-psis (json:decode-json-from-string (get-all-topic-psis)))) - (is (= (length json-psis) (length (elephant:get-instances-by-class 'd:TopicC)))) + (let ((json-psis + (json:decode-json-from-string (get-all-topic-psis :revision rev-0)))) + (is (= (length json-psis) + (length (elephant:get-instances-by-class 'd:TopicC)))) (loop for topic-psis in json-psis do (cond - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#topic") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#topic") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#association") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#association") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#occurrence") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#occurrence") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#class-instance") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#class-instance") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#class") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#class") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype") + ((string= + (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#subtype") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#subtype") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.topicmaps.org/xtm/1.0/core.xtm#display") + ((string= (first topic-psis) + "http://www.topicmaps.org/xtm/1.0/core.xtm#display") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.topicmaps.org/iso13250/model/type-instance") + ((string= (first topic-psis) + "http://psi.topicmaps.org/iso13250/model/type-instance") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.topicmaps.org/iso13250/model/type") + ((string= (first topic-psis) + "http://psi.topicmaps.org/iso13250/model/type") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.topicmaps.org/iso13250/model/instance") + ((string= (first topic-psis) + "http://psi.topicmaps.org/iso13250/model/instance") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/topic-type") + ((string= + (first topic-psis) + "http://www.networkedplanet.com/psi/npcl/meta-types/topic-type") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/service") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/service") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/standard") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/standard") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/semanticstandard") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/semanticstandard") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/technicalstandard") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/technicalstandard") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/subject") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/subject") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/occurrence-type") + ((string= + (first topic-psis) + "http://www.networkedplanet.com/psi/npcl/meta-types/occurrence-type") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/association-type") + ((string= + (first topic-psis) + "http://www.networkedplanet.com/psi/npcl/meta-types/association-type") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://www.networkedplanet.com/psi/npcl/meta-types/association-role-type") + ((string= + (first topic-psis) + "http://www.networkedplanet.com/psi/npcl/meta-types/association-role-type") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/topicInTaxonomy") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/topicInTaxonomy") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/long-name") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/long-name") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/standardHasStatus") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/standardHasStatus") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/status/InternationalStandard") + ((string= (first topic-psis) + "http://psi.egovpt.org/status/InternationalStandard") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/description") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/description") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/standardValidFromDate") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/standardValidFromDate") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/links") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/links") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/topicIsAboutSubject") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/topicIsAboutSubject") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/isNarrowerSubject") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/isNarrowerSubject") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/narrowerSubject") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/narrowerSubject") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/broaderSubject") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/broaderSubject") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/standardIsAboutSubject") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/standardIsAboutSubject") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/SubjectRoleType") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/SubjectRoleType") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/StandardRoleType") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/StandardRoleType") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/ServiceRoleType") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/ServiceRoleType") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/types/serviceUsesStandard") + ((string= (first topic-psis) + "http://psi.egovpt.org/types/serviceUsesStandard") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…") + ((string= + (first topic-psis) + "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/standard/Topic+Maps+2002") + ((string= (first topic-psis) + "http://psi.egovpt.org/standard/Topic+Maps+2002") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/subject/Web+Services") + ((string= (first topic-psis) + "http://psi.egovpt.org/subject/Web+Services") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/subject/Semantic+Description") + ((string= (first topic-psis) + "http://psi.egovpt.org/subject/Semantic+Description") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/subject/Data") + ((string= (first topic-psis) + "http://psi.egovpt.org/subject/Data") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/subject/GeoData") + ((string= (first topic-psis) + "http://psi.egovpt.org/subject/GeoData") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/subject/Legal+Data") + ((string= (first topic-psis) + "http://psi.egovpt.org/subject/Legal+Data") (is (= (length topic-psis) 1))) - ((string= (first topic-psis) "http://psi.egovpt.org/service/Norwegian+National+Curriculum") + ((string= + (first topic-psis) + "http://psi.egovpt.org/service/Norwegian+National+Curriculum") (is (= (length topic-psis) 1))) - ((or (string= (first topic-psis) "http://psi.egovpt.org/service/Google+Maps") - (string= (first topic-psis) "http://maps.google.com")) + ((or (string= (first topic-psis) + "http://psi.egovpt.org/service/Google+Maps") + (string= (first topic-psis) + "http://maps.google.com")) (is (= (length topic-psis) 2)) - (is (or (string= (second topic-psis) "http://psi.egovpt.org/service/Google+Maps") - (string= (second topic-psis) "http://maps.google.com")))) + (is (or (string= (second topic-psis) + "http://psi.egovpt.org/service/Google+Maps") + (string= (second topic-psis) + "http://maps.google.com")))) (t (is-true (format t "found bad topic-psis: ~a" topic-psis))))))))) Modified: trunk/src/unit_tests/rdf_exporter_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_exporter_test.lisp (original) +++ trunk/src/unit_tests/rdf_exporter_test.lisp Sun Oct 10 05:41:19 2010 @@ -349,14 +349,14 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "28.08.1749")))))) (died-id (concatenate 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "22.03.1832"))))))) (is-true (property-p me *sw-arc* "born" :nodeID born-id)) @@ -395,7 +395,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "31.12.1782"))))))) (is-true (property-p me *sw-arc* "dateRange" @@ -423,7 +423,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1772"))))))) (is-true (property-p me *sw-arc* "dateRange" @@ -431,7 +431,7 @@ (test test-zauberlehrling - "Tests the resoruce zauberlehrling." + "Tests the resource zauberlehrling." (with-fixture rdf-exporter-test-db () (let ((zauberlehrlings (get-resources-by-uri "http://some.where/poem/Der_Zauberlehrling"))) @@ -465,7 +465,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1797"))))))) (is-true (property-p me *sw-arc* "dateRange" @@ -600,7 +600,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "28.08.1749"))))))) @@ -627,7 +627,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "22.03.1832"))))))) @@ -654,7 +654,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1797"))))))) @@ -675,7 +675,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1782"))))))) @@ -696,7 +696,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1772"))))))) @@ -717,7 +717,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "http://de.wikipedia.org/wiki/Schiller"))))))) @@ -872,7 +872,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "http://de.wikipedia.org/wiki/Schiller"))))))) Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Sun Oct 10 05:41:19 2010 @@ -1054,9 +1054,11 @@ :document-id document-id) (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20)) (let ((first-node (get-item-by-id "http://test-tm/first-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (first-type (get-item-by-id "http://test-tm/first-type" - :xtm-id document-id))) + :xtm-id document-id + :revision 0))) (is-true first-node) (is (= (length (d::versions first-node)) 1)) (is (= (d::start-revision (first (d::versions first-node))) @@ -1066,11 +1068,12 @@ (is (= (length (d:player-in-roles first-node)) 1)) (is (= (length (d:player-in-roles first-type)) 1)) (let ((instance-role - (first (d:player-in-roles first-node))) + (first (d:player-in-roles first-node :revision 0))) (type-role - (first (d:player-in-roles first-type))) + (first (d:player-in-roles first-type :revision 0))) (type-assoc - (d:parent (first (d:player-in-roles first-node))))) + (d:parent (first (d:player-in-roles first-node :revision 0)) + :revision 0))) (is (= (length (d::versions type-assoc)) 1)) (is (= (d::start-revision (first (d::versions type-assoc))) revision-2)) @@ -1080,7 +1083,7 @@ (d:get-item-by-psi *type-psi*))) (is (eql (d:instance-of type-assoc) (d:get-item-by-psi *type-instance-psi*))) - (is (= (length (d:roles type-assoc)) 2)) + (is (= (length (d:roles type-assoc :revision 0)) 2)) (is (= (length (d:psis first-node)) 1)) (is (= (length (d:psis first-type)) 1)) (is (string= (d:uri (first (d:psis first-node))) @@ -1095,19 +1098,24 @@ tm-id revision-3 :document-id document-id)) (let ((first-node (get-item-by-id "http://test-tm/first-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (first-type (get-item-by-id "http://test-tm/first-type" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (second-node (get-item-by-id "second-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (second-type (get-item-by-id "http://test-tm/second-type" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (third-node (get-item-by-id "http://test-tm#third-node" - :xtm-id document-id))) + :xtm-id document-id + :revision 0))) (is-true second-node) - (is-false (d:psis second-node)) - (is-false (d:occurrences second-node)) - (is-false (d:names second-node)) + (is-false (d:psis second-node :revision 0)) + (is-false (d:occurrences second-node :revision 0)) + (is-false (d:names second-node :revision 0)) (is-true first-node) (is (= (length (d::versions first-node)) 2)) (is-true (find-if #'(lambda(x) @@ -1119,18 +1127,22 @@ (= (d::end-revision x) 0))) (d::versions first-node))) (let ((instance-role - (first (d:player-in-roles first-node))) + (first (d:player-in-roles first-node :revision 0))) (type-role - (first (d:player-in-roles first-type))) + (first (d:player-in-roles first-type :revision 0))) (type-assoc - (d:parent (first (d:player-in-roles first-node)))) - (type-topic (get-item-by-psi *type-psi*)) - (instance-topic (get-item-by-psi *instance-psi*)) - (type-instance-topic (get-item-by-psi *type-instance-psi*)) - (supertype-topic (get-item-by-psi *supertype-psi*)) - (subtype-topic (get-item-by-psi *subtype-psi*)) + (d:parent (first (d:player-in-roles first-node + :revision 0)))) + (type-topic (get-item-by-psi *type-psi* :revision 0)) + (instance-topic (get-item-by-psi *instance-psi* :revision 0)) + (type-instance-topic (get-item-by-psi *type-instance-psi* + :revision 0)) + (supertype-topic (get-item-by-psi *supertype-psi* + :revision 0)) + (subtype-topic (get-item-by-psi *subtype-psi* + :revision 0)) (supertype-subtype-topic - (get-item-by-psi *supertype-subtype-psi*)) + (get-item-by-psi *supertype-subtype-psi* :revision 0)) (arc2-occurrence (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "arc-2")) (arc3-occurrence @@ -1138,18 +1150,19 @@ 'd:OccurrenceC 'd:charvalue "<root><content type=\"anyContent\">content</content></root>")) (fifth-node (d:get-item-by-id "http://test-tm#fifth-node" - :xtm-id document-id))) - (is (eql (d:instance-of instance-role) - (d:get-item-by-psi *instance-psi*))) - (is (eql (d:instance-of type-role) - (d:get-item-by-psi *type-psi*))) - (is (eql (d:instance-of type-assoc) - (d:get-item-by-psi *type-instance-psi*))) - (is (= (length (d:roles type-assoc)) 2)) - (is (= (length (d:psis first-node)) 1)) - (is (= (length (d:psis first-type)) 1)) - (is (= (length (d::versions type-assoc)) 1)) - (is (= (length (d:player-in-roles second-node)) 2)) + :xtm-id document-id + :revision 0))) + (is (eql (d:instance-of instance-role :revision 0) + (d:get-item-by-psi *instance-psi* :revision 0))) + (is (eql (d:instance-of type-role :revision 0) + (d:get-item-by-psi *type-psi* :revision 0))) + (is (eql (d:instance-of type-assoc :revision 0) + (d:get-item-by-psi *type-instance-psi* :revision 0))) + (is (= (length (d:roles type-assoc :revision 0)) 2)) + (is (= (length (d:psis first-node :revision 0)) 1)) + (is (= (length (d:psis first-type :revision 0)) 1)) + (is (= (length (d::versions type-assoc)) 2)) + (is (= (length (d:player-in-roles second-node :revision 0)) 2)) (is-true (find-if #'(lambda(x) (and (eql (d:instance-of x) instance-topic) @@ -1176,16 +1189,16 @@ (d:player-in-roles third-node))) (is-true arc2-occurrence) (is (string= (d:datatype arc2-occurrence) "http://test-tm/dt")) - (is-false (d:psis (d:topic arc2-occurrence))) - (is (= (length (d::versions (d:topic arc2-occurrence))) 1)) + (is-false (d:psis (d:parent arc2-occurrence))) + (is (= (length (d::versions (d:parent arc2-occurrence))) 1)) (is (= (d::start-revision - (first (d::versions (d:topic arc2-occurrence)))) + (first (d::versions (d:parent arc2-occurrence)))) revision-3)) (is (= (d::end-revision - (first (d::versions (d:topic arc2-occurrence)))) 0)) + (first (d::versions (d:parent arc2-occurrence)))) 0)) (is-true arc3-occurrence) - (is (= (length (d:psis (d:topic arc3-occurrence))))) - (is (string= (d:uri (first (d:psis (d:topic arc3-occurrence)))) + (is (= (length (d:psis (d:parent arc3-occurrence))))) + (is (string= (d:uri (first (d:psis (d:parent arc3-occurrence)))) "http://test-tm/fourth-node")) (is (string= (d:datatype arc3-occurrence) *xml-string*)) @@ -1592,8 +1605,8 @@ (concatenate 'string arcs "firstName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) goethe))) occs) 1)) @@ -1604,8 +1617,8 @@ (concatenate 'string arcs "lastName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) goethe))) occs) 1)) @@ -1616,8 +1629,8 @@ (concatenate 'string arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) weimar))) occs) 1)) @@ -1628,8 +1641,8 @@ (concatenate 'string arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) frankfurt))) occs) 1)) @@ -1641,8 +1654,8 @@ (string= *xml-string* (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) germany))) occs) 1)) @@ -1655,8 +1668,8 @@ (string= (d:charvalue x) "Der Zauberlehrling") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) zauberlehrling))) occs) 1)) @@ -1668,8 +1681,8 @@ (= 0 (length (d:themes x))) (string= (d:charvalue x) "Prometheus") (string= *xml-string* (d:datatype x)) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) prometheus))) occs) 1)) @@ -1682,8 +1695,8 @@ (string= (d:charvalue x) "Der Erlkönig") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) erlkoenig))) occs) 1)) @@ -1696,8 +1709,8 @@ (string= (d:charvalue x) "Hat der alte Hexenmeister ...") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) zauberlehrling))) occs) 1)) @@ -1711,8 +1724,8 @@ " Bedecke deinen Himmel, Zeus, ... ") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) prometheus))) occs) 1)) @@ -1726,8 +1739,8 @@ "Wer reitet so spät durch Nacht und Wind? ...") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) erlkoenig))) occs) 1)) @@ -1738,8 +1751,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) weimar))) occs) 1)) @@ -1750,8 +1763,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) frankfurt))) occs) 1)) @@ -1762,8 +1775,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) berlin))) occs) 1)) @@ -1774,8 +1787,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) germany))) occs) 1)) @@ -1786,7 +1799,7 @@ (concatenate 'string arcs "date")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2)) (is (= (count-if @@ -1797,7 +1810,7 @@ (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 1)) @@ -1808,7 +1821,7 @@ (concatenate 'string arcs "start")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2)) @@ -1820,7 +1833,7 @@ (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 1)) (is (= (count-if @@ -1830,7 +1843,7 @@ (concatenate 'string arcs "end")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2))))) @@ -2937,16 +2950,18 @@ (is-true marge-ln) (is (string= (d:charvalue marge-fn) "Marjorie")) (is (string= (d:charvalue marge-ln) "Simpson")) - (is (= (length (d:variants marge-fn)) 1)) - (is (= (length (d:themes (first (d:variants marge-fn)))) 1)) - (is (eql (first (d:themes (first (d:variants marge-fn)))) display)) - (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge")) - (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*)) + (is (= (length (d:variants marge-fn :revision 0)) 1)) + (is (= (length (d:themes (first (d:variants marge-fn :revision 0)) + :revision 0)) 1)) + (is (eql (first (d:themes (first (d:variants marge-fn :revision 0)) + :revision 0)) display)) + (is (string= (d:charvalue (first (d:variants marge-fn :revision 0))) "Marge")) + (is (string= (d:datatype (first (d:variants marge-fn :revision 0))) *xml-string*)) (is-true marge-occ) (is (string= (d:charvalue marge-occ) "Housewife")) (is (string= (d:datatype marge-occ) *xml-string*)) - (is (= (length (d:themes marge-occ)) 0)) - (is (= (length (d:psis marge)) 2)))))) + (is (= (length (d:themes marge-occ :revision 0)) 0)) + (is (= (length (d:psis marge :revision 0)) 2)))))) (test test-full-mapping-homer Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Sun Oct 10 05:41:19 2010 @@ -58,7 +58,7 @@ (test test-merge-reifier-topics - "Tests the function merge-reifier-topics." + "Tests the function merge-constructs." (let ((db-dir "data_base") (revision-1 100) (revision-2 200)) @@ -147,7 +147,7 @@ :start-revision revision-1))) (let ((name-1-1 (make-construct 'NameC :item-identifiers nil - :topic topic-1 + :parent topic-1 :themes (list scope-1) :instance-of name-type :charvalue "name-1-1" @@ -156,7 +156,7 @@ :item-identifiers (list (make-instance 'ItemIdentifierC :uri "name-2-1-ii-1" :start-revision revision-1)) - :topic topic-2 + :parent topic-2 :themes (list scope-2) :instance-of nil :charvalue "name-2-1" @@ -165,7 +165,7 @@ :item-identifiers (list (make-instance 'ItemIdentifierC :uri "occurrence-1-1-ii-1" :start-revision revision-1)) - :topic topic-2 + :parent topic-2 :themes (list scope-1 scope-2) :instance-of occurrence-type :charvalue "occurrence-2-1" @@ -173,7 +173,7 @@ :start-revision revision-2)) (occurrence-2-2 (make-construct 'OccurrenceC :item-identifiers nil - :topic topic-2 + :parent topic-2 :themes nil :instance-of occurrence-type :charvalue "occurrence-2-2" @@ -181,7 +181,7 @@ :start-revision revision-2)) (test-name (make-construct 'NameC :item-identifiers nil - :topic scope-2 + :parent scope-2 :themes (list scope-1 topic-2) :instance-of topic-2 :charvalue "test-name" @@ -194,19 +194,21 @@ (list (list :instance-of role-type :player topic-1 + :start-revision revision-2 :item-identifiers (list (make-instance 'ItemIdentifierC :uri "role-1" - :start-revision revision-1))) + :start-revision revision-2))) (list :instance-of role-type :player topic-2 + :start-revision revision-2 :item-identifiers (list (make-instance 'ItemIdentifierC :uri "role-2" - :start-revision revision-1)))) - :start-revision revision-1))) + :start-revision revision-2)))) + :start-revision revision-2))) (is (= (length (elephant:get-instances-by-class 'TopicC)) 8)) - (datamodel::merge-reifier-topics topic-1 topic-2) + (d::merge-constructs topic-1 topic-2 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'TopicC)) 7)) (is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2) (item-identifiers topic-1))) @@ -220,7 +222,7 @@ (is (= (length (union (names topic-1) (list name-1-1 name-2-1))) (length (list name-1-1 name-2-1)))) - (is (= (length (union (occurrences topic-1) + (is (= (length (union (occurrences topic-1 :revision 0) (list occurrence-2-1 occurrence-2-2))) (length (list occurrence-2-1 occurrence-2-2)))) (is (= (length (union (d:used-as-type topic-1) @@ -229,9 +231,9 @@ (is (= (length (union (d:used-as-theme topic-1) (list test-name))) (length (list test-name)))) - (is (eql (player (first (roles assoc))) topic-1)) - (is (eql (player (second (roles assoc))) topic-1)) - ;;TODO: check all objects and their version-infos + (is (= (length (roles assoc :revision 0)) 1)) + (is (= (length (d::slot-p assoc 'd::roles)) 2)) + (is (eql (player (first (roles assoc :revision 0)) :revision 0) topic-1)) (elephant:close-store)))))) @@ -282,21 +284,21 @@ (is-true reifier-married-assoc) (is-true reifier-husband-role) (is (eql (reifier homer-occurrence) reifier-occurrence)) - (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reified-construct reifier-occurrence) homer-occurrence)) (is (eql (reifier homer-name) reifier-name)) - (is (eql (reified reifier-name) homer-name)) + (is (eql (reified-construct reifier-name) homer-name)) (is (eql (reifier homer-variant) reifier-variant)) - (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reified-construct reifier-variant) homer-variant)) (is (eql (reifier married-assoc) reifier-married-assoc)) - (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reified-construct reifier-married-assoc) married-assoc)) (is (eql (reifier husband-role) reifier-husband-role)) - (is (eql (reified reifier-husband-role) husband-role)) + (is (eql (reified-construct reifier-husband-role) husband-role)) (is-true (handler-case (progn (d::delete-construct homer-occurrence) t) (condition () nil))) (is-false (occurrences homer)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) (elephant:close-store)))))) @@ -346,21 +348,21 @@ (is-true reifier-married-assoc) (is-true reifier-husband-role) (is (eql (reifier homer-occurrence) reifier-occurrence)) - (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reified-construct reifier-occurrence) homer-occurrence)) (is (eql (reifier homer-name) reifier-name)) - (is (eql (reified reifier-name) homer-name)) + (is (eql (reified-construct reifier-name) homer-name)) (is (eql (reifier homer-variant) reifier-variant)) - (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reified-construct reifier-variant) homer-variant)) (is (eql (reifier married-assoc) reifier-married-assoc)) - (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reified-construct reifier-married-assoc) married-assoc)) (is (eql (reifier husband-role) reifier-husband-role)) - (is (eql (reified reifier-husband-role) husband-role)) + (is (eql (reified-construct reifier-husband-role) husband-role)) (is-true (handler-case (progn (d::delete-construct homer-occurrence) t) (condition () nil))) (is-false (occurrences homer)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) (elephant:close-store)))))) @@ -621,9 +623,9 @@ "http://test/arcs/arc4")) (is (= (length (d:used-as-type arc1)) 1)) (is (eql (reifier (first (d:used-as-type arc1))) reification-1)) - (is (eql (reified reification-1) (first (d:used-as-type arc1)))) + (is (eql (reified-construct reification-1) (first (d:used-as-type arc1)))) (is (eql (reifier (first (d:used-as-type arc3))) reification-2)) - (is (eql (reified reification-2) (first (d:used-as-type arc3)))))))) + (is (eql (reified-construct reification-2) (first (d:used-as-type arc3)))))))) (elephant:close-store)) @@ -647,13 +649,13 @@ (is-true married) (is (= (length (used-as-type married)) 1)) (is-true (reifier (first (used-as-type married)))) - (is-true (reified (reifier (first (used-as-type married))))) + (is-true (reified-construct (reifier (first (used-as-type married))))) (is (= (length (psis (reifier (first (used-as-type married))))) 1)) (is (string= (uri (first (psis (reifier (first (used-as-type married)))))) "http://test-tm#married-arc")) (is (= (length (occurrences bart)) 1)) (is-true (reifier (first (occurrences bart)))) - (is-true (reified (reifier (first (occurrences bart))))) + (is-true (reified-construct (reifier (first (occurrences bart))))) (is (string= (uri (first (psis (reifier (first (occurrences bart)))))) "http://test-tm#lastName-arc")))) (elephant:close-store)) @@ -680,17 +682,17 @@ (is (= (length (variants name)) 1)) (let ((variant (first (variants name)))) (is-true (reifier name)) - (is-true (reified (reifier name))) + (is-true (reified-construct (reifier name))) (is (= (length (psis (reifier name))) 1)) (is (string= (uri (first (psis (reifier name)))) (concatenate 'string tm-id "lisa-name"))) (is-true (reifier variant)) - (is-true (reified (reifier variant))) + (is-true (reified-construct (reifier variant))) (is (= (length (psis (reifier variant))) 1)) (is (string= (uri (first (psis (reifier variant)))) (concatenate 'string tm-id "lisa-name-variant"))) (is-true (reifier occurrence)) - (is-true (reified (reifier occurrence))) + (is-true (reified-construct (reifier occurrence))) (is (= (length (psis (reifier occurrence))) 1)) (is (string= (uri (first (psis (reifier occurrence)))) (concatenate 'string tm-id "lisa-occurrence"))))))) @@ -717,7 +719,7 @@ (is (typep (first (used-as-type friendship)) 'd:AssociationC)) (let ((friendship-association (first (used-as-type friendship)))) (is-true (reifier friendship-association)) - (is-true (reified (reifier friendship-association))) + (is-true (reified-construct (reifier friendship-association))) (is (= (length (psis (reifier friendship-association))) 1)) (is (string= (uri (first (psis (reifier friendship-association)))) (concatenate 'string tm-id "friendship-association"))) @@ -728,7 +730,7 @@ (roles friendship-association)))) (is-true carl-role) (is-true (reifier carl-role)) - (is-true (reified (reifier carl-role))) + (is-true (reified-construct (reifier carl-role))) (is (= (length (psis (reifier carl-role))) 1)) (is (string= (uri (first (psis (reifier carl-role)))) (concatenate 'string tm-id "friend-role"))))))) Modified: trunk/src/unit_tests/versions_test.lisp ============================================================================== --- trunk/src/unit_tests/versions_test.lisp (original) +++ trunk/src/unit_tests/versions_test.lisp Sun Oct 10 05:41:19 2010 @@ -28,6 +28,7 @@ :test-get-item-by-id-t301 :test-get-item-by-id-common-lisp :test-mark-as-deleted + :test-instance-of-t64 :test-norwegian-curriculum-association :test-change-lists :test-changed-p @@ -43,327 +44,327 @@ (in-suite versions-test) (test test-get-item-by-id-t100 () - "test certain characteristics of -http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata -of which two revisions are created, the original one and then one during the -merge with *XTM-MERGE1*" - (with-fixture merge-test-db () - - (let - ((top-t100-current (get-item-by-id "t100" :xtm-id *TEST-TM*)) - (top-t100-first (get-item-by-id "t100" :xtm-id *TEST-TM* :revision fixtures::revision1)) - (top-t100-second (get-item-by-id "t100" :xtm-id *TEST-TM* :revision fixtures::revision2)) - (link-topic (get-item-by-id "t55" :xtm-id *TEST-TM* :revision fixtures::revision2))) - - (is (eq top-t100-current top-t100-second)) - (is (eq top-t100-current top-t100-first)) - - (is (= 2 (length (names top-t100-current)))) - (with-revision fixtures::revision1 - (is (= 1 (length (names top-t100-first))))) - (is (string= (charvalue (first (names top-t100-first))) - "ISO 19115")) - (with-revision fixtures::revision2 - (is (= 2 (length (names top-t100-second)))) - (is (= 5 (length (occurrences top-t100-second)))) - (is (eq link-topic (get-item-by-id "t50" :xtm-id "merge1"))) ;the topic with t55 in notificationbase has the id t50 in merge1 - (is (eq link-topic (instance-of (fifth (occurrences top-t100-second)))))) - - (is (string= (charvalue (first (names top-t100-second))) - "ISO 19115")) - (is (string= (charvalue (second (names top-t100-second))) - "Geo Data")) - - (is (= 5 (length (occurrences top-t100-current)))) - (is (= 2 (length (item-identifiers top-t100-current)))) - - (with-revision fixtures::revision1 - (is (= 4 (length (occurrences top-t100-first)))) - (is (= 1 (length (item-identifiers top-t100-first))))) + "test certain characteristics of + http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada… + of which two revisions are created, the original one and then one during the + merge with *XTM-MERGE1*" + (with-fixture merge-test-db () + (let + ((top-t100-current (get-item-by-id "t100" :xtm-id *TEST-TM*)) + (top-t100-first (get-item-by-id "t100" :xtm-id *TEST-TM* + :revision fixtures::revision1)) + (top-t100-second (get-item-by-id "t100" :xtm-id *TEST-TM* + :revision fixtures::revision2)) + (link-topic (get-item-by-id "t55" :xtm-id *TEST-TM* + :revision fixtures::revision2))) + (is (eq top-t100-current top-t100-second)) + (is (eq top-t100-current top-t100-first)) + (is (= 2 (length (names top-t100-current)))) + (with-revision fixtures::revision1 + (is (= 1 (length (names top-t100-first))))) + (is (string= (charvalue (first (names top-t100-first))) + "ISO 19115")) + (with-revision fixtures::revision2 + (is (= 2 (length (names top-t100-second)))) + (is (= 5 (length (occurrences top-t100-second)))) + (is (eq link-topic (get-item-by-id "t50" :xtm-id "merge1"))) ;the topic with t55 in notificationbase has the id t50 in merge1 + (is (eq link-topic (instance-of (fifth (occurrences top-t100-second)))))) + (is (string= (charvalue (first (names top-t100-second))) + "ISO 19115")) + (is (string= (charvalue (second (names top-t100-second))) + "Geo Data")) + (is (= 5 (length (occurrences top-t100-current)))) + (is (= 2 (length (item-identifiers top-t100-current)))) + (with-revision fixtures::revision1 + (is (= 4 (length (occurrences top-t100-first)))) + (is (= 1 (length (item-identifiers top-t100-first))))) + (is (= 2 (length (elephant:get-instances-by-class 'd:TopicMapC))))))) - (is (= 2 (length (elephant:get-instances-by-class 'd:TopicMapC))))))) (test test-get-item-by-id-t301 () - "test characteristics of http://psi.egovpt.org/service/Google+Maps which -occurs twice in notificationbase.xtm but is not subsequently revised" - (with-fixture merge-test-db () - (let - ((top-t301-current (get-item-by-id "t301" :xtm-id *TEST-TM*)) - (top-t301-first (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision1)) - (top-t301-second (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision2))) + "test characteristics of http://psi.egovpt.org/service/Google+Maps which + occurs twice in notificationbase.xtm but is not subsequently revised" + (with-fixture merge-test-db () + (let + ((top-t301-current (get-item-by-id "t301" :xtm-id *TEST-TM*)) + (top-t301-first (get-item-by-id "t301a" :xtm-id *TEST-TM* + :revision fixtures::revision1)) + (top-t301-second (get-item-by-id "t301a" :xtm-id *TEST-TM* + :revision fixtures::revision2))) + (is (eq top-t301-current top-t301-first)) + (is (eq top-t301-current top-t301-second))))) - (is (eq top-t301-current top-t301-first)) - (is (eq top-t301-current top-t301-second))))) (test test-get-item-by-id-common-lisp () - "Get the http://psi.egovpt.org/standard/Common+Lisp topic that was first -introduced in merge1 and then modified in merge2" - (with-fixture merge-test-db () - (let - ((top-cl-current (get-item-by-id "t100" :xtm-id "merge2")) - (top-cl-first (get-item-by-id "t100" :xtm-id "merge2" :revision fixtures::revision1)) - (top-cl-second (get-item-by-id "t100" :xtm-id "merge2" :revision fixtures::revision2))) - (is-false top-cl-first) ;did not yet exist then and should thus be nil - (is (eq top-cl-second top-cl-current)) - (is (= 1 (length (names top-cl-current)))) - (with-revision fixtures::revision2 - (is (= 1 (length (item-identifiers top-cl-second))))) - (is (= 2 (length (item-identifiers top-cl-current)))) - (with-revision fixtures::revision2 - (is (= 1 (length (occurrences top-cl-second))))) - (is (= 2 (length (occurrences top-cl-current))))))) + "Get the http://psi.egovpt.org/standard/Common+Lisp topic that was first + introduced in merge1 and then modified in merge2" + (with-fixture merge-test-db () + (let + ((top-cl-current (get-item-by-id "t100" :xtm-id "merge2" + :revision fixtures::revision3)) + (top-cl-first (get-item-by-id "t100" :xtm-id "merge2" + :revision fixtures::revision1)) + (top-cl-second (get-item-by-id "t100" :xtm-id "merge1" + :revision fixtures::revision2))) + (is-false top-cl-first) + (is (eq top-cl-second top-cl-current)) + (is (= 1 (length (names top-cl-current)))) + (with-revision fixtures::revision2 + (is (= 1 (length (item-identifiers top-cl-second))))) + (is (= 2 (length (item-identifiers top-cl-current)))) + (with-revision fixtures::revision2 + (is (= 1 (length (occurrences top-cl-second))))) + (is (= 2 (length (occurrences top-cl-current))))))) -;; tests for: - history of roles and associations -;; - get list of all revisions -;; - get changes - (test test-norwegian-curriculum-association () - "Check the various incarnations of the norwegian curriculum -associations across its revisions" - (with-fixture merge-test-db () - (let* - ((norwegian-curr-topic - (get-item-by-id "t300" :xtm-id *TEST-TM*)) - - (curriculum-assoc ;this is the only "true" association in which the - ;Norwegian Curriculum is a player in revision1 - (parent - (second ;the first one is the instanceOf association - (player-in-roles - norwegian-curr-topic)))) - (scoped-curriculum-assoc ;this one is added in revision3 - (parent - (third - (player-in-roles - norwegian-curr-topic)))) - (semantic-standard-topic - (get-item-by-id "t3a" :xtm-id *TEST-TM*))) - (is (string= "http://psi.egovpt.org/service/Norwegian+National+Curriculum" - (uri (first (psis norwegian-curr-topic))))) - (is (= 1 (length (item-identifiers curriculum-assoc)))) - (is (= 3 (length (psis semantic-standard-topic)))) - - (with-revision fixtures::revision1 - ;one explicit association and the association resulting - ;from instanceOf - (is (= 2 (length (player-in-roles norwegian-curr-topic)))) - (is-false (item-identifiers curriculum-assoc)) - (is-false (used-as-theme semantic-standard-topic)) - ) - (with-revision fixtures::revision2 - ;one explicit association and the association resulting - ;from instanceOf - (is (= 2 (length (player-in-roles norwegian-curr-topic)))) - (is (= 1 (length (item-identifiers curriculum-assoc)))) - (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) - (is (= 2 (length (item-identifiers (second (roles curriculum-assoc)))))) - (is-false (used-as-theme semantic-standard-topic))) - - (with-revision fixtures::revision3 - ;two explicit associations and the association resulting - ;from instanceOf - (is (= 3 (length (player-in-roles norwegian-curr-topic)))) - (is (= 1 (length (item-identifiers curriculum-assoc)))) - (is (eq semantic-standard-topic (first (themes scoped-curriculum-assoc)))) - (is (= 1 (length (used-as-theme semantic-standard-topic)))) - (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) - (is (= 3 (length (item-identifiers (second (roles curriculum-assoc)))))))))) + "Check the various incarnations of the norwegian curriculum + associations across its revisions" + (with-fixture merge-test-db () + (let* + ((norwegian-curr-topic + (get-item-by-id "t300" :xtm-id *TEST-TM* :revision fixtures::revision3)) + + (curriculum-assoc ;this is the only "true" association in which the + ;Norwegian Curriculum is a player in revision1 + (parent + (second ;the first one is the instanceOf association + (player-in-roles + norwegian-curr-topic :revision fixtures::revision3)) + :revision fixtures::revision3)) + (scoped-curriculum-assoc ;this one is added in revision3 + (parent + (third + (player-in-roles + norwegian-curr-topic :revision fixtures::revision3)) + :revision fixtures::revision3)) + (semantic-standard-topic + (get-item-by-id "t3a" :xtm-id *TEST-TM* :revision fixtures::revision3))) + (is (string= "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + (uri (first (psis norwegian-curr-topic + :revision fixtures::revision3))))) + (is (= 1 (length (item-identifiers curriculum-assoc + :revision fixtures::revision3)))) + (is (= 3 (length (psis semantic-standard-topic + :revision fixtures::revision3)))) + (with-revision fixtures::revision1 + ;one explicit association and the association resulting + ;from instanceOf + (is (= 2 (length (player-in-roles norwegian-curr-topic)))) + (is-false (item-identifiers curriculum-assoc)) + (is-false (used-as-theme semantic-standard-topic))) + (with-revision fixtures::revision2 + ;one explicit association and the association resulting + ;from instanceOf + (is (= 2 (length (player-in-roles norwegian-curr-topic)))) + (is (= 1 (length (item-identifiers curriculum-assoc)))) + (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) + (is (= 2 (length (item-identifiers (second (roles curriculum-assoc)))))) + (is-false (used-as-theme semantic-standard-topic))) + (with-revision fixtures::revision3 + ;two explicit associations and the association resulting + ;from instanceOf + (is (= 3 (length (player-in-roles norwegian-curr-topic)))) + (is (= 1 (length (item-identifiers curriculum-assoc)))) + (is (eq semantic-standard-topic (first (themes scoped-curriculum-assoc)))) + (is (= 1 (length (used-as-theme semantic-standard-topic)))) + (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) + (is (= 3 (length (item-identifiers (second (roles curriculum-assoc)))))))))) (test test-instance-of-t64 () - "Check if all instances of t64 are properly registered." - (with-fixture merge-test-db () - (let - ((t63 (get-item-by-id "t63" :xtm-id *TEST-TM*)) - (t64 (get-item-by-id "t64" :xtm-id *TEST-TM*)) - (t300 (get-item-by-id "t300" :xtm-id *TEST-TM*))) - (with-revision fixtures::revision1 - (let - ((assocs (used-as-type t64))) - (is (= 2 (length assocs))) - (is (= (internal-id t63) - (internal-id (instance-of (first (roles (first assocs))))))) - (is (= (internal-id t300) - (internal-id (player (first (roles (first assocs))))))))) - (with-revision fixtures::revision2 - (let - ((assocs (used-as-type t64))) - (is (= 2 (length assocs))))) - (with-revision fixtures::revision3 - (let - ((assocs (used-as-type t64))) - (is (= 3 (length assocs)))))))) + "Check if all instances of t64 are properly registered." + (with-fixture merge-test-db () + (let ((t63 (get-item-by-id "t63" :xtm-id *TEST-TM* + :revision fixtures::revision3)) + (t64 (get-item-by-id "t64" :xtm-id *TEST-TM* + :revision fixtures::revision3)) + (t300 (get-item-by-id "t300" :xtm-id *TEST-TM* + :revision fixtures::revision3))) + (with-revision fixtures::revision1 + (let ((assocs (used-as-type t64))) + (is (= 2 (length assocs))) + (is (= (d::internal-id t63) + (d::internal-id (instance-of (first (roles (first assocs))))))) + (is (= (d::internal-id t300) + (d::internal-id (player (first (roles (first assocs))))))))) + (with-revision fixtures::revision2 + (let ((assocs (used-as-type t64))) + (is (= 2 (length assocs))))) + (with-revision fixtures::revision3 + (let ((assocs (used-as-type t64))) + (is (= 3 (length assocs)))))))) + (test test-change-lists () - "Check various properties of changes applied to Isidor in this -test suite" - (with-fixture merge-test-db () - (let - ((all-revision-set (get-all-revisions)) - (fragments-revision2 - (get-fragments fixtures::revision2)) - (fragments-revision3 - (get-fragments fixtures::revision3))) - (is (= 3 (length all-revision-set))) - (is (= fixtures::revision1 (first all-revision-set))) - (is (= fixtures::revision2 (second all-revision-set))) - (is (= fixtures::revision3 (third all-revision-set))) - - ;topics changed in revision2 / merge1: topic type, service, - ;standard, semantic standard, standardHasStatus, geo data - ;standard, common lisp, norwegian curriculum - (is (= 8 (length fragments-revision2))) - - ;topics changed in revision3 / merge2: semantic standard, norwegian curriculum, common lisp - (is (= 3 (length fragments-revision3))) - (is (= fixtures::revision3 - (revision (first fragments-revision3)))) - (is (string= - "http://psi.egovpt.org/types/semanticstandard" - (uri (first (psis (topic (first fragments-revision3))))))) - - (format t "semantic-standard: ~a~&" - (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) - :test #'string=)) - (is-false - (set-exclusive-or - '("http://psi.egovpt.org/types/standard") - (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) - :test #'string=) - :test #'string=)) - ; 0 if we ignore instanceOf associations - (is (= 0 (length (associations (first fragments-revision3))))) - - (is (string= - "http://psi.egovpt.org/standard/Common+Lisp" - (uri (first (psis (topic (third fragments-revision3))))))) - (is-false - (set-exclusive-or - '("http://psi.egovpt.org/types/standard" - "http://psi.egovpt.org/types/links";) - "http://www.topicmaps.org/xtm/1.0/core.xtm#sort" - "http://www.topicmaps.org/xtm/1.0/core.xtm#display" - "http://psi.egovpt.org/types/long-name") - (remove-duplicates - (map 'list - #'uri - (mapcan #'psis (referenced-topics (third fragments-revision3)))) - :test #'string=) - :test #'string=)) - ;0 if we ignore instanceOf associations - (is (= 0 (length (associations (third fragments-revision3))))) - - (is (string= - "http://psi.egovpt.org/service/Norwegian+National+Curriculum" - (uri (first (psis (topic (second fragments-revision3))))))) - (is-false - (set-exclusive-or - '("http://psi.egovpt.org/types/service" - "http://psi.egovpt.org/types/description" - "http://psi.egovpt.org/types/links" - "http://psi.egovpt.org/types/serviceUsesStandard" - "http://psi.egovpt.org/types/StandardRoleType" - "http://psi.egovpt.org/standard/Topic+Maps+2002" - "http://psi.egovpt.org/types/ServiceRoleType" - "http://psi.egovpt.org/types/semanticstandard" ;these three PSIS all stand for the same topic - "http://psi.egovpt.org/types/greatstandard" - "http://psi.egovpt.org/types/knowledgestandard") - (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (second fragments-revision3)))) - :test #'string=) - :test #'string=)) - ;the second time round the object should be fetched from the - ;cache - (is (equal fragments-revision3 - (get-fragments fixtures::revision3))) - ))) + "Check various properties of changes applied to Isidor in this + test suite" + (with-fixture merge-test-db () + (let ((all-revision-set (get-all-revisions)) + (fragments-revision2 + (get-fragments fixtures::revision2)) + (fragments-revision3 + (get-fragments fixtures::revision3))) + (is (= 3 (length all-revision-set))) + (is (= fixtures::revision1 (first all-revision-set))) + (is (= fixtures::revision2 (second all-revision-set))) + (is (= fixtures::revision3 (third all-revision-set))) + ;topics changed in revision2 / merge1: topic type, service, + ;standard, semantic standard, standardHasStatus, geo data + ;standard, common lisp, norwegian curriculum + (is (= 8 (length fragments-revision2))) + ;topics changed in revision3 / merge2: semantic standard, + ;norwegian curriculum, common lisp + (is (= 3 (length fragments-revision3))) + (is (= fixtures::revision3 + (revision (first fragments-revision3)))) + (is (string= + "http://psi.egovpt.org/types/semanticstandard" + (uri (first (psis (topic (first fragments-revision3))))))) + (format t "semantic-standard: ~a~&" + (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) + :test #'string=)) + (is-false + (set-exclusive-or + '("http://psi.egovpt.org/types/standard") + (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) + :test #'string=) + :test #'string=)) + ;0 if we ignore instanceOf associations + (is (= 0 (length (associations (first fragments-revision3))))) + (is (string= "http://psi.egovpt.org/standard/Common+Lisp" + (uri (first (psis (topic (third fragments-revision3))))))) + (is-false + (set-exclusive-or + '("http://psi.egovpt.org/types/standard" + "http://psi.egovpt.org/types/links";) + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort" + "http://www.topicmaps.org/xtm/1.0/core.xtm#display" + "http://psi.egovpt.org/types/long-name") + (remove-duplicates + (map 'list + #'uri + (mapcan #'psis (referenced-topics (third fragments-revision3)))) + :test #'string=) + :test #'string=)) + ;0 if we ignore instanceOf associations + (is (= 0 (length (associations (third fragments-revision3))))) + (is (string= + "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + (uri (first (psis (topic (second fragments-revision3))))))) + (is-false + (set-exclusive-or + '("http://psi.egovpt.org/types/service" + "http://psi.egovpt.org/types/description" + "http://psi.egovpt.org/types/links" + "http://psi.egovpt.org/types/serviceUsesStandard" + "http://psi.egovpt.org/types/StandardRoleType" + "http://psi.egovpt.org/standard/Topic+Maps+2002" + "http://psi.egovpt.org/types/ServiceRoleType" + ;these three PSIS all stand for the same topic + "http://psi.egovpt.org/types/semanticstandard" + "http://psi.egovpt.org/types/greatstandard" + "http://psi.egovpt.org/types/knowledgestandard") + (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (second fragments-revision3)))) + :test #'string=) + :test #'string=)) + ;the second time round the object should be fetched from the + ;cache + (is (equal fragments-revision3 + (get-fragments fixtures::revision3)))))) + (test test-changed-p () - "Check the is-changed mechanism" - (with-fixture merge-test-db () - (let* - ((service-topic ;changed in merge1 - (get-item-by-id "t2" :xtm-id *TEST-TM*)) - (service-name ;does not change after creation - (first (names service-topic))) - (google-maps-topic ;does not change after creation - (get-item-by-id "t301a" :xtm-id *TEST-TM*)) - (norwegian-curr-topic ;changes in merge1 (only through + "Check the is-changed mechanism" + (with-fixture merge-test-db () + (let* + ((service-topic ;changed in merge1 + (get-item-by-id "t2" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (service-name ;does not change after creation + (first (names service-topic :revision fixtures::revision1))) + (google-maps-topic ;does not change after creation + (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (norwegian-curr-topic ;changes in merge1 (only through ;association) and merge2 (again through association) - (get-item-by-id "t300" :xtm-id *TEST-TM*)) - (geodata-topic ;does not change after creation - (get-item-by-id "t203" :xtm-id *TEST-TM*)) ;the subject "geodata", not the standard - (semantic-standard-topic ;changes in merge1 and merge2 - (get-item-by-id "t3a" :xtm-id *TEST-TM*)) - (common-lisp-topic ;created in merge1 and changed in merge2 - (get-item-by-id "t100" :xtm-id "merge1")) - (subject-geodata-assoc ;does not change after creation - (parent - (second ;the first one is the instanceOf association - (player-in-roles - geodata-topic)))) - (norwegian-curriculum-assoc ;changes in merge1 and merge2 - (identified-construct - (elephant:get-instance-by-value 'ItemIdentifierC 'uri - "http://psi.egovpt.org/itemIdentifiers#assoc_6")))) - - (is-true (changed-p service-name fixtures::revision1)) - (is-false (changed-p service-name fixtures::revision2)) - (is-false (changed-p service-name fixtures::revision3)) - - (is-true (changed-p service-topic fixtures::revision1)) - (is-true (changed-p service-topic fixtures::revision2)) - (is-false (changed-p service-topic fixtures::revision3)) - - (is-true (changed-p google-maps-topic fixtures::revision1)) - (is-false (changed-p google-maps-topic fixtures::revision2)) - (is-false (changed-p google-maps-topic fixtures::revision3)) - - (is-true (changed-p norwegian-curr-topic fixtures::revision1)) - (is-true (changed-p norwegian-curr-topic fixtures::revision2)) - (is-true (changed-p norwegian-curr-topic fixtures::revision3)) - - (is-true (changed-p geodata-topic fixtures::revision1)) - (is-false (changed-p geodata-topic fixtures::revision2)) - (is-false (changed-p geodata-topic fixtures::revision3)) - - (is-true (changed-p semantic-standard-topic fixtures::revision1)) - (is-true (changed-p semantic-standard-topic fixtures::revision2)) - (is-true (changed-p semantic-standard-topic fixtures::revision3)) - - (is-false (changed-p common-lisp-topic fixtures::revision1)) ;didn't even exist then - (is-true (changed-p common-lisp-topic fixtures::revision2)) - (is-true (changed-p common-lisp-topic fixtures::revision3)) - - (is-true (changed-p subject-geodata-assoc fixtures::revision1)) - (is-false (changed-p subject-geodata-assoc fixtures::revision2)) - (is-false (changed-p subject-geodata-assoc fixtures::revision3)) - - (is-true (changed-p norwegian-curriculum-assoc fixtures::revision1)) - (is-true (changed-p norwegian-curriculum-assoc fixtures::revision2)) - (is-true (changed-p norwegian-curriculum-assoc fixtures::revision3))))) + (get-item-by-id "t300" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (geodata-topic ;does not change after creation + (get-item-by-id "t203" :xtm-id *TEST-TM* :revision fixtures::revision1)) ;the subject "geodata", not the standard + (semantic-standard-topic ;changes in merge1 and merge2 + (get-item-by-id "t3a" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (common-lisp-topic ;created in merge1 and changed in merge2 + (get-item-by-id "t100" :xtm-id "merge1" :revision fixtures::revision2)) + (subject-geodata-assoc ;does not change after creation + (parent + (second ;the first one is the instanceOf association + (player-in-roles + geodata-topic :revision fixtures::revision1)) + :revision fixtures::revision1)) + (norwegian-curriculum-assoc ;changes in merge1 and merge2 + (identified-construct + (elephant:get-instance-by-value + 'ItemIdentifierC 'uri + "http://psi.egovpt.org/itemIdentifiers#assoc_6") + :revision fixtures::revision2))) + (is-true (changed-p service-name fixtures::revision1)) + (is-false (changed-p service-name fixtures::revision2)) + (is-false (changed-p service-name fixtures::revision3)) + (is-true (changed-p service-topic fixtures::revision1)) + (is-true (changed-p service-topic fixtures::revision2)) + (is-false (changed-p service-topic fixtures::revision3)) + (is-true (changed-p google-maps-topic fixtures::revision1)) + (is-false (changed-p google-maps-topic fixtures::revision2)) + (is-false (changed-p google-maps-topic fixtures::revision3)) + (is-true (changed-p norwegian-curr-topic fixtures::revision1)) + (is-true (changed-p norwegian-curr-topic fixtures::revision2)) + (is-true (changed-p norwegian-curr-topic fixtures::revision3)) + (is-true (changed-p geodata-topic fixtures::revision1)) + (is-false (changed-p geodata-topic fixtures::revision2)) + (is-false (changed-p geodata-topic fixtures::revision3)) + (is-true (changed-p semantic-standard-topic fixtures::revision1)) + (is-true (changed-p semantic-standard-topic fixtures::revision2)) + (is-true (changed-p semantic-standard-topic fixtures::revision3)) + (is-false (changed-p common-lisp-topic fixtures::revision1)) ;didn't even exist then + (is-true (changed-p common-lisp-topic fixtures::revision2)) + (is-true (changed-p common-lisp-topic fixtures::revision3)) + (is-true (changed-p subject-geodata-assoc fixtures::revision1)) + (is-false (changed-p subject-geodata-assoc fixtures::revision2)) + (is-false (changed-p subject-geodata-assoc fixtures::revision3)) + (is-true (changed-p norwegian-curriculum-assoc fixtures::revision1)) + (is-true (changed-p norwegian-curriculum-assoc fixtures::revision2)) + (is-true (changed-p norwegian-curriculum-assoc fixtures::revision3)) + (delete-name service-topic service-name :revision fixtures::revision3) + (is-true (changed-p service-topic fixtures::revision3))))) + (test test-mark-as-deleted () - "Check the pseudo-deletion mechanism" - (with-fixture merge-test-db () - (let - ((norwegian-curriculum-topic - (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum" :revision fixtures::revision3)) - (semantic-standard-topic - (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" :revision fixtures::revision3))) - (is-true norwegian-curriculum-topic) - (is-true semantic-standard-topic) - (mark-as-deleted norwegian-curriculum-topic :source-locator "http://psi.egovpt.org/" - :revision fixtures::revision3) - (is-false (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum" - :revision (1+ fixtures::revision3))) - (mark-as-deleted semantic-standard-topic :source-locator "http://blablub.egovpt.org/" - :revision fixtures::revision3) - (is-true (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" - :revision (1+ fixtures::revision3))) - (is (= 0 (d::end-revision (d::get-most-recent-version-info semantic-standard-topic)))) - (is (= (d::end-revision (first (last (d::versions norwegian-curriculum-topic)))) - (d::end-revision (d::get-most-recent-version-info norwegian-curriculum-topic))))))) + "Check the pseudo-deletion mechanism" + (with-fixture merge-test-db () + (let + ((norwegian-curriculum-topic + (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + :revision fixtures::revision3)) + (semantic-standard-topic + (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" + :revision fixtures::revision3))) + (is-true norwegian-curriculum-topic) + (is-true semantic-standard-topic) + (mark-as-deleted norwegian-curriculum-topic + :source-locator "http://psi.egovpt.org/" + :revision fixtures::revision3) + (is-false (get-item-by-psi + "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + :revision (1+ fixtures::revision3))) + (mark-as-deleted semantic-standard-topic + :source-locator "http://blablub.egovpt.org/" + :revision fixtures::revision3) + (is-true (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" + :revision (1+ fixtures::revision3))) + (is (= 0 (d::end-revision + (d::get-most-recent-version-info semantic-standard-topic)))) + (is (= (d::end-revision + (first (last (d::versions norwegian-curriculum-topic)))) + (d::end-revision + (d::get-most-recent-version-info norwegian-curriculum-topic))))))) Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Sun Oct 10 05:41:19 2010 @@ -60,7 +60,7 @@ (defun init-*ns-map* () - "Initializes the variable *ns-map* woith some prefixes and corresponding + "Initializes the variable *ns-map* with some prefixes and corresponding namepsaces. So the predifend namespaces are not contain ed twice." (setf *ns-map* (list (list :prefix "isi" @@ -75,8 +75,8 @@ (defmacro with-property (construct &body body) "Generates a property element with a corresponding namespace - and tag name before executing the body. This macro is for usin - in occurrences and association that are mapped to RDF properties." + and tag name before executing the body. This macro is for using + in occurrences and associations that are mapped to RDF properties." `(let ((ns-list (separate-uri (rdf-li-or-uri (uri (first (psis (instance-of ,construct)))))))) @@ -216,7 +216,7 @@ (declare (TopicC topic)) (if (psis topic) (cxml:attribute "rdf:resource" - (if (reified topic) + (if (reified-construct topic) (let ((psi (get-reifier-psi topic))) (if psi (concatenate 'string "#" (get-reifier-uri topic)) @@ -306,7 +306,7 @@ (make-isi-type *tm2rdf-name-type-uri*) (export-reifier-as-mapping construct) (map 'list #'to-rdf-elem (item-identifiers construct)) - (when (slot-boundp construct 'instance-of) + (when (instance-of construct) (cxml:with-element "isi:nametype" (make-topic-reference (instance-of construct)))) (scopes-to-rdf-elems construct) @@ -592,7 +592,7 @@ (t-occs (occurrences construct)) (t-assocs (list-rdf-mapped-associations construct))) (if psi - (if (reified construct) + (if (reified-construct construct) (let ((reifier-uri (get-reifier-uri construct))) (if reifier-uri (cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct))) @@ -627,7 +627,7 @@ (ii (item-identifiers construct)) (sl (locators construct))) (if psi - (if (reified construct) + (if (reified-construct construct) (let ((reifier-uri (get-reifier-uri construct))) (if reifier-uri (cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct))) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Sun Oct 10 05:41:19 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))) @@ -67,12 +67,12 @@ ((top (from-topic-elem-to-stub top-elem revision :xtm-id *rdf-core-xtm*))) - (add-to-topicmap xml-importer::tm top)))))))) + (add-to-tm xml-importer::tm top)))))))) (defun import-dom (rdf-dom start-revision &key (tm-id nil) (document-id *document-id*)) - "Imports the entire dom of a rdf-xml-file." + "Imports the entire dom of an rdf-xml-file." (setf *_n-map* nil) ;in case of an failed last call (tm-id-p tm-id "import-dom") (let ((xml-base (get-xml-base rdf-dom)) @@ -137,7 +137,7 @@ (defun import-arc (elem tm-id start-revision &key (document-id *document-id*) (parent-xml-base nil) (parent-xml-lang nil)) - "Imports a property that is an blank_node and continues the recursion + "Imports a property that is a blank_node and continues the recursion on this element." (declare (dom:element elem)) (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) @@ -351,11 +351,13 @@ (error "~aone of the role types ~a ~a is missing!" err-pref *supertype-psi* *subtype-psi*)) (let ((a-roles (list (list :instance-of role-type-1 - :player super-top) + :player super-top + :start-revision start-revision) (list :instance-of role-type-2 - :player sub-top)))) + :player sub-top + :start-revision start-revision)))) (let ((assoc - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -392,11 +394,13 @@ (error "~aone of the role types ~a ~a is missing!" err-pref *type-psi* *instance-psi*)) (let ((a-roles (list (list :instance-of roletype-1 - :player type-top) + :player type-top + :start-revision start-revision) (list :instance-of roletype-2 - :player instance-top)))) + :player instance-top + :start-revision start-revision)))) (let ((assoc - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -420,40 +424,35 @@ (ii-uri (unless (or about ID) (concatenate 'string *rdf2tm-blank-node-prefix* (or nodeID UUID))))) - (let ((top - ;seems like there is a bug in d:get-item-by-id: - ;this functions returns an emtpy topic although there is no one - ;with a corresponding topic id and/or version. - ;Thus the version is temporary checked manually. - (let ((inner-top - (get-item-by-id topic-id :xtm-id document-id - :revision start-revision))) - (when inner-top - (let ((versions (d::versions inner-top))) - (when (find-if #'(lambda(version) - (= start-revision - (d::start-revision version))) - versions) - inner-top)))))) + (let ((top (get-item-by-id topic-id :xtm-id document-id + :revision start-revision))) (if top - top + (progn + (d::add-to-version-history top :start-revision start-revision) + top) (elephant:ensure-transaction (:txn-nosync t) (let ((psis (when psi-uri (list - (make-instance 'PersistentIdC + (make-construct 'PersistentIdC :uri psi-uri :start-revision start-revision)))) (iis (when ii-uri (list - (make-instance 'ItemIdentifierC + (make-construct 'ItemIdentifierC :uri ii-uri - :start-revision start-revision))))) + :start-revision start-revision)))) + (topic-ids (when topic-id + (list + (make-construct 'TopicIdentificationC + :uri topic-id + :xtm-id document-id + :start-revision start-revision))))) (handler-case (let ((top - (add-to-topicmap + (add-to-tm tm (make-construct - 'TopicC - :topicid topic-id + 'TopicC + :topic-identifiers topic-ids :psis psis :item-identifiers iis :xtm-id document-id @@ -498,11 +497,13 @@ (type-top (make-topic-stub type nil nil nil start-revision tm :document-id document-id))) (let ((roles (list (list :instance-of role-type-1 - :player player-1) + :player player-1 + :start-revision start-revision) (list :instance-of role-type-2 - :player top)))) + :player top + :start-revision start-revision)))) (let ((assoc - (add-to-topicmap tm (make-construct 'AssociationC + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision :instance-of type-top :roles roles)))) @@ -527,11 +528,13 @@ (make-topic-stub *rdf2tm-object* nil nil nil start-revision tm :document-id document-id))) (let ((roles (list (list :instance-of role-type-1 - :player subject-topic) + :player subject-topic + :start-revision start-revision) (list :instance-of role-type-2 - :player object-topic)))) + :player object-topic + :start-revision start-revision)))) (let ((assoc - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision :instance-of associationtype-topic @@ -541,13 +544,14 @@ -(defun make-reification(reifier-id reifiable-construct start-revision tm &key (document-id *document-id*)) +(defun make-reification(reifier-id reifiable-construct start-revision tm &key + (document-id *document-id*)) (declare (string reifier-id)) (declare (ReifiableConstructC reifiable-construct)) (declare (TopicMapC tm)) (let ((reifier-topic (make-topic-stub reifier-id nil nil nil start-revision tm :document-id document-id))) - (add-reifier reifiable-construct reifier-topic))) + (add-reifier reifiable-construct reifier-topic :revision start-revision))) (defun make-occurrence (top literal start-revision tm-id @@ -572,7 +576,7 @@ (let ((occurrence (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes (when lang-top (list lang-top)) :instance-of type-top Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Sun Oct 10 05:41:19 2010 @@ -57,42 +57,51 @@ (let ((type-topic (get-item-by-psi type-psi :revision start-revision))) (when type-topic - (when (and (not (player-in-roles type-topic)) - (not (used-as-type type-topic)) - (not (used-as-theme type-topic))) + (when (and (not (player-in-roles type-topic :revision start-revision)) + (not (used-as-type type-topic :revision start-revision)) + (not (used-as-theme type-topic :revision start-revision))) (d::delete-construct type-topic))))) -(defun delete-instance-of-association(instance-topic type-topic) +(defun delete-instance-of-association(instance-topic type-topic start-revision) "Deletes a type-instance associaiton that corresponds with the passed parameters." (when (and instance-topic type-topic) - (let ((instance (get-item-by-psi *instance-psi*)) - (type-instance (get-item-by-psi *type-instance-psi*)) - (type (get-item-by-psi *type-psi*))) - (declare (TopicC instance-topic type-topic)) + (let ((instance (get-item-by-psi *instance-psi* :revision start-revision)) + (type-instance (get-item-by-psi *type-instance-psi* + :revision start-revision)) + (type (get-item-by-psi *type-psi* :revision start-revision))) + (declare (TopicC instance-topic type-topic) + (integer start-revision)) (let ((assocs (remove-if #'null (map 'list #'(lambda(role) - (when (and (eql (instance-of role) instance) - (eql (instance-of (parent role)) - type-instance)) - (parent role))) - (player-in-roles instance-topic))))) + (when (and + (eql (instance-of role :revision start-revision) + instance) + (eql (instance-of + (parent role :revision start-revision) + :revision start-revision) + type-instance)) + (parent role :revision start-revision))) + (player-in-roles instance-topic :revision start-revision))))) (map 'list #'(lambda(assoc) - (when (find-if #'(lambda(role) - (and (eql (instance-of role) type) - (eql (player role) type-topic))) - (roles assoc)) + (when (find-if + #'(lambda(role) + (and (eql (instance-of role :revision start-revision) + type) + (eql (player role :revision start-revision) + type-topic))) + (roles assoc :revision start-revision)) (d::delete-construct assoc))) assocs) nil)))) -(defun delete-related-associations (top) +(defun delete-related-associations (top start-revision) "Deletes all associaitons related to the passed topic." - (dolist (assoc-role (player-in-roles top)) + (dolist (assoc-role (player-in-roles top :revision start-revision)) (d::delete-construct (parent assoc-role))) top) @@ -141,11 +150,12 @@ (when (= 0 (length role-players)) (error "~aexpect one player but found: ~a" err-pref (length role-players))) - (delete-related-associations role-top) + (delete-related-associations role-top start-revision) (d::delete-construct role-top) (list :instance-of (first types) :player (first role-players) :item-identifiers ids + :start-revision start-revision :reifiers reifiers))))) @@ -185,10 +195,10 @@ (when (= 0 (length assoc-roles)) (error "~aexpect at least one role but found: ~a" err-pref (length assoc-roles))) - (delete-related-associations assoc-top) + (delete-related-associations assoc-top start-revision) (d::delete-construct assoc-top) (with-tm (start-revision document-id tm-id) - (add-to-topicmap + (add-to-tm xml-importer::tm (let ((association (make-construct 'AssociationC @@ -208,10 +218,11 @@ assoc-roles))) (when found-item (dolist (reifier-topic (getf found-item :reifiers)) - (add-reifier association-role reifier-topic))))) - (roles association)) + (add-reifier association-role reifier-topic + :revision start-revision))))) + (roles association :revision start-revision)) (dolist (reifier-topic reifier-topics) - (add-reifier association reifier-topic)) + (add-reifier association reifier-topic :revision start-revision)) association))))))) @@ -229,9 +240,9 @@ (new-item-ids (map-isi-identifiers top start-revision)) (occurrence-topics (get-isi-occurrences top start-revision)) (name-topics (get-isi-names top start-revision))) - (bound-subject-identifiers top new-psis) - (bound-subject-locators top new-locators) - (bound-item-identifiers top new-item-ids) + (bound-subject-identifiers top new-psis start-revision) + (bound-subject-locators top new-locators start-revision) + (bound-item-identifiers top new-item-ids start-revision) (map 'list #'(lambda(occurrence-topic) (map-isi-occurrence top occurrence-topic start-revision)) occurrence-topics) @@ -267,7 +278,7 @@ variant-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi *tm2rdf-value-property*))) + (get-item-by-psi *tm2rdf-value-property* :revision start-revision))) (let ((scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value-and-datatype @@ -283,7 +294,7 @@ (reifiers (get-isi-reifiers variant-top start-revision))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) - (delete-related-associations variant-top) + (delete-related-associations variant-top start-revision) (d::delete-construct variant-top) (let ((variant (make-construct 'VariantC @@ -292,9 +303,9 @@ :themes scopes :charvalue (getf value-and-datatype :value) :datatype (getf value-and-datatype :datatype) - :name name))) + :parent name))) (dolist (reifier-topic reifiers) - (add-reifier variant reifier-topic)) + (add-reifier variant reifier-topic :revision start-revision)) variant))))) @@ -312,7 +323,7 @@ name-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi *tm2rdf-value-property*)) + (get-item-by-psi *tm2rdf-value-property* :revision start-revision)) (variant-topics (get-isi-variants name-top start-revision))) (let ((type (let ((fn-types (get-players-by-role-type @@ -335,7 +346,7 @@ (map 'list #'d::delete-construct scope-assocs) (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue value :instance-of type :item-identifiers ids @@ -344,10 +355,10 @@ (map-isi-variant name variant-topic start-revision)) variant-topics) - (delete-related-associations name-top) + (delete-related-associations name-top start-revision) (d::delete-construct name-top) (dolist (reifier-topic reifiers) - (add-reifier name reifier-topic)) + (add-reifier name reifier-topic :revision start-revision)) name))))) @@ -403,19 +414,19 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) - (delete-related-associations occ-top) + (delete-related-associations occ-top start-revision) (d::delete-construct occ-top) (let ((occurrence (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes scopes :item-identifiers ids :instance-of (first types) :charvalue (getf value-and-datatype :value) :datatype (getf value-and-datatype :datatype)))) (dolist (reifier-topic reifiers) - (add-reifier occurrence reifier-topic)) + (add-reifier occurrence reifier-topic :revision start-revision)) occurrence))))) @@ -448,12 +459,15 @@ (let ((topics-in-tm (with-tm (start-revision document-id tm-id) (intersection isi-topics (topics xml-importer::tm))))) - (map 'list #'(lambda(top) - (map 'list - #'(lambda(role) - (when (find (parent role) assocs) - (d::delete-construct (parent role)))) - (player-in-roles top))) + (map 'list + #'(lambda(top) + (map 'list + #'(lambda(role) + (when (find (parent role :revision start-revision) + assocs) + (d::delete-construct + (parent role :revision start-revision)))) + (player-in-roles top :revision start-revision))) topics-in-tm) topics-in-tm)))))) @@ -497,11 +511,13 @@ (map 'list #'(lambda(assoc) (let ((role - (find-if #'(lambda(role) - (eql role-type (instance-of role))) - (roles assoc)))) + (find-if + #'(lambda(role) + (eql role-type (instance-of role + :revision start-revision))) + (roles assoc :revision start-revision)))) (when role - (player role)))) + (player role :revision start-revision)))) associations)))) players))) @@ -517,16 +533,18 @@ (remove-if #'null (map 'list #'(lambda(occurrence) - (let ((type (instance-of occurrence))) + (let ((type + (instance-of occurrence + :revision start-revision))) (let ((type-psi (find-if #'(lambda(psi) (string= occurrence-type-uri (uri psi))) - (psis type)))) + (psis type :revision start-revision)))) (when type-psi occurrence)))) - (occurrences top))))) + (occurrences top :revision start-revision))))) identifier-occs))) @@ -560,42 +578,45 @@ ids))))) -(defun bound-item-identifiers (construct identifiers) +(defun bound-item-identifiers (construct identifiers start-revision) "Bounds the passed item-identifier to the passed construct." (declare (ReifiableConstructC construct)) (dolist (id identifiers) (declare (ItemIdentifierC id)) (if (find-if #'(lambda(ii) - (string= (uri ii) (uri id))) - (item-identifiers construct)) + (and (string= (uri ii) (uri id)) + (not (eql ii id)))) + (item-identifiers construct :revision start-revision)) (d::delete-construct id) - (setf (identified-construct id) construct))) + (add-item-identifier construct id :revision start-revision))) construct) -(defun bound-subject-identifiers (top identifiers) +(defun bound-subject-identifiers (top identifiers start-revision) "Bounds the passed psis to the passed topic." (declare (TopicC top)) (dolist (id identifiers) (declare (PersistentIdC id)) (if (find-if #'(lambda(psi) - (string= (uri psi) (uri id))) - (psis top)) + (and (string= (uri psi) (uri id)) + (not (eql psi id)))) + (psis top :revision start-revision)) (d::delete-construct id) - (setf (identified-construct id) top))) + (add-psi top id :revision start-revision))) top) -(defun bound-subject-locators (top locators) +(defun bound-subject-locators (top locators start-revision) "Bounds the passed locators to the passed topic." (declare (TopicC top)) (dolist (id locators) (declare (SubjectLocatorC id)) (if (find-if #'(lambda(locator) - (string= (uri locator) (uri id))) - (locators top)) + (and (string= (uri locator) (uri id)) + (not (eql locator id)))) + (locators top :revision start-revision)) (d::delete-construct id) - (setf (identified-construct id) top))) + (add-locator top id :revision start-revision))) top) Modified: trunk/src/xml/xtm/exporter.lisp ============================================================================== --- trunk/src/xml/xtm/exporter.lisp (original) +++ trunk/src/xml/xtm/exporter.lisp Sun Oct 10 05:41:19 2010 @@ -10,26 +10,35 @@ (in-package :exporter) -;; (defun instanceofs-to-elem (ios) -;; (when ios -;; (map 'list (lambda (io) (cxml:with-element "t:instanceOf" (ref-to-elem io))) ios))) - - -(defun list-extern-associations () +(defun list-extern-associations (&key (revision *TM-REVISION*)) "gets all instances of AssociationC - which does not realize an instanceOf relationship in the db" (let ((instance-topic (identified-construct - (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/instance"))) + (elephant:get-instance-by-value 'PersistentIdC 'uri *instance-psi*))) (type-topic (identified-construct - (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/type")))) - (loop for item in (elephant:get-instances-by-class 'AssociationC) - when (not (and (or (eq instance-topic (instance-of (first (roles item)))) - (eq instance-topic (instance-of (second (roles item))))) - (or (eq type-topic (instance-of (first (roles item)))) - (eq type-topic (instance-of (second (roles item))))))) + (elephant:get-instance-by-value 'PersistentIdC 'uri *type-psi*)))) + (loop for item in (d:get-all-associations revision) + when (and (= (length (roles item :revision revision)) 2) + (not (and (or (eq instance-topic + (instance-of (first (roles item + :revision revision)) + :revision revision)) + (eq instance-topic + (instance-of (second (roles item + :revision revision)) + :revision revision))) + (or (eq type-topic + (instance-of (first (roles item + :revision revision)) + :revision revision)) + (eq type-topic + (instance-of (second (roles item + :revision revision)) + :revision revision)))))) collect item))) + (defmacro with-xtm2.0 (&body body) "helper macro to build the Topic Map element" `(cxml:with-namespace ("t" *xtm2.0-ns*) @@ -47,6 +56,7 @@ "t:topicMap" :empty ,@body)))) + (defmacro export-to-elem (tm to-elem) `(setf *export-tm* ,tm) `(format t "*export-tm*: ~a" *export-tm*) @@ -57,12 +67,13 @@ (map 'list #'(lambda(top) (d:find-item-by-revision top revision)) - (if ,tm - (union - (d:topics ,tm) (d:associations ,tm)) - (union - (elephant:get-instances-by-class 'd:TopicC) - (list-extern-associations))))))) + (if ,tm + (union + (d:topics ,tm) (d:associations ,tm)) + (union + (elephant:get-instances-by-class 'd:TopicC) + (list-extern-associations :revision revision))))))) + (defun export-xtm (xtm-path &key tm-id @@ -80,9 +91,11 @@ (cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil) (if (eq xtm-format '2.0) (with-xtm2.0 - (export-to-elem tm #'to-elem)) + (export-to-elem tm #'(lambda(elem) + (to-elem elem revision)))) (with-xtm1.0 - (export-to-elem tm #'to-elem-xtm1.0))))))))) + (export-to-elem tm #'(lambda(elem) + (to-elem-xtm1.0 elem revision))))))))))) (defun export-xtm-to-string (&key @@ -97,9 +110,11 @@ (cxml:with-xml-output (cxml:make-string-sink :canonical nil) (if (eq xtm-format '2.0) (with-xtm2.0 - (export-to-elem tm #'to-elem)) + (export-to-elem tm #'(lambda(elem) + (to-elem elem revision)))) (with-xtm1.0 - (export-to-elem tm #'to-elem-xtm1.0)))))))) + (export-to-elem tm #'(lambda(elem) + (to-elem-xtm1.0 elem revision)))))))))) (defun export-xtm-fragment (fragment &key (xtm-format '2.0)) @@ -109,7 +124,6 @@ (cxml:with-xml-output (cxml:make-string-sink :canonical nil) (if (eq xtm-format '2.0) (with-xtm2.0 - (to-elem fragment)) + (to-elem fragment (revision fragment))) (with-xtm1.0 - (to-elem-xtm1.0 fragment))))))) - \ No newline at end of file + (to-elem-xtm1.0 fragment (revision fragment)))))))) \ No newline at end of file Modified: trunk/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm1.0.lisp Sun Oct 10 05:41:19 2010 @@ -12,7 +12,11 @@ (:import-from :constants *XTM2.0-NS* *XTM1.0-NS* - *XTM1.0-XLINK*) + *XTM1.0-XLINK* + *type-psi* + *instance-psi* + *xml-uri* + *xml-string*) (:export :to-elem :to-string :list-extern-associations @@ -24,35 +28,40 @@ (defparameter *export-tm* nil "TopicMap which is exported (nil if all is to be exported") -(defgeneric to-elem-xtm1.0 (instance) +(defgeneric to-elem-xtm1.0 (instance revision) (:documentation "converts the Topic Maps construct instance to an XTM 1.0 element")) -(defun to-topicRef-elem-xtm1.0 (topic) - (declare (TopicC topic)) +(defun to-topicRef-elem-xtm1.0 (topic revision) + (declare (TopicC topic) + (type (or integer nil) revision)) (cxml:with-element "t:topicRef" - (cxml:attribute "xlink:href" (format nil "#~a" (topicid topic))))) + (cxml:attribute "xlink:href" (format nil "#~a" (topic-id topic revision))))) -(defun to-reifier-elem-xtm1.0 (reifiable-construct) +(defun to-reifier-elem-xtm1.0 (reifiable-construct revision) "Exports an ID indicating a reifier. The reifier is only exported if the reifier-topic contains a PSI starting with #. This may cause differences since the xtm2.0 defines the referencing of reifiers with item-identifiers." - (declare (ReifiableConstructC reifiable-construct)) - (when (reifier reifiable-construct) + (declare (ReifiableConstructC reifiable-construct) + (type (or integer nil) revision)) + (when (reifier reifiable-construct :revision revision) (let ((reifier-psi (find-if #'(lambda(x) (when (and (stringp (uri x)) (> (length (uri x)) 0)) (eql (elt (uri x) 0) #\#))) - (psis (reifier reifiable-construct))))) + (psis (reifier reifiable-construct :revision revision) + :revision revision)))) (when reifier-psi - (cxml:attribute "id" (subseq (uri reifier-psi) 1 (length (uri reifier-psi)))))))) + (cxml:attribute "id" (subseq (uri reifier-psi) 1 + (length (uri reifier-psi)))))))) -(defun to-resourceX-elem-xtm1.0 (characteristic) - (declare (CharacteristicC characteristic)) +(defun to-resourceX-elem-xtm1.0 (characteristic revision) + (declare (CharacteristicC characteristic) + (type (or integer nil) revision)) (let ((characteristic-value (if (slot-boundp characteristic 'charvalue) (charvalue characteristic) @@ -66,136 +75,175 @@ (cxml:attribute "xlink:href" (let ((ref-topic (when (and (> (length characteristic-value) 0) (eql (elt characteristic-value 0) #\#)) - (get-item-by-id (subseq characteristic-value 1))))) - (if ref-topic (concatenate 'string "#" (topicid ref-topic)) characteristic-value)))) + (get-item-by-id (subseq characteristic-value 1) :revision revision)))) + (if ref-topic (concatenate 'string "#" (topic-id ref-topic revision)) characteristic-value)))) (cxml:with-element "t:resourceData" (cxml:text characteristic-value))))) -(defmethod to-elem-xtm1.0 ((psi PersistentIdC)) +(defmethod to-elem-xtm1.0 ((psi PersistentIdC) revision) "subjectIndocatorRef = element subjectIndicatorRef { href }" + (declare (ignorable revision)) (cxml:with-element "t:subjectIndicatorRef" (cxml:attribute "xlink:href" (uri psi)))) -(defun to-instanceOf-elem-xtm1.0 (topic) +(defun to-instanceOf-elem-xtm1.0 (topic revision) "instanceOf = element instanceOf { topicRef | subjectIndicatorRef }" - (declare (TopicC topic)) + (declare (TopicC topic) + (type (or integer nil) revision)) (cxml:with-element "t:instanceOf" (cxml:with-element "t:topicRef" - (cxml:attribute "xlink:href" (concatenate 'string "#" (topicid topic)))))) + (cxml:attribute "xlink:href" (concatenate 'string "#" (topic-id topic revision)))))) -(defun to-subjectIdentity-elem-xtm1.0 (psis locator) +(defun to-subjectIdentity-elem-xtm1.0 (psis locator revision) "subjectIdentity = element subjectIdentity { resourceRef?, (topicRef | subjectIndicatorRef)* }" + (declare (type (or integer nil) revision)) (when (or psis locator) (cxml:with-element "t:subjectIdentity" - (map 'list #'to-elem-xtm1.0 psis) + (map 'list #'(lambda(x) + (to-elem-xtm1.0 x revision)) + psis) (when locator (cxml:with-element "t:resourceRef" (cxml:attribute "xlink:href" (uri locator))))))) -(defun to-scope-elem-xtm1.0 (scopable) +(defun to-scope-elem-xtm1.0 (scopable revision) "scope = element scope { (topicRef | resourceRef | subjectIndicatorRef)+ }" - (declare (ScopableC scopable)) + (declare (ScopableC scopable) + (type (or integer nil) revision)) (cxml:with-element "t:scope" - (to-topicRef-elem-xtm1.0 (first (themes scopable))))) + (to-topicRef-elem-xtm1.0 (first (themes scopable :revision revision)) revision))) -(defmethod to-elem-xtm1.0 ((variant VariantC)) +(defmethod to-elem-xtm1.0 ((variant VariantC) revision) "variant = element { parameters, variantName?, variant* }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:variant" - (to-reifier-elem-xtm1.0 variant) - (when (themes variant) + (to-reifier-elem-xtm1.0 variant revision) + (when (themes variant :revision revision) (cxml:with-element "t:parameters" - (map 'list #'to-topicRef-elem-xtm1.0 (themes variant)))) + (map 'list #'(lambda(x) + (to-topicRef-elem-xtm1.0 x revision)) + (themes variant :revision revision)))) (cxml:with-element "t:variantName" - (to-resourceX-elem-xtm1.0 variant)))) + (to-resourceX-elem-xtm1.0 variant revision)))) -(defmethod to-elem-xtm1.0 ((name NameC)) +(defmethod to-elem-xtm1.0 ((name NameC) revision) "baseName = element baseName { scope?, baseNameString, variant* }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:baseName" - (to-reifier-elem-xtm1.0 name) - (when (themes name) - (to-scope-elem-xtm1.0 name)) + (to-reifier-elem-xtm1.0 name revision) + (when (themes name :revision revision) + (to-scope-elem-xtm1.0 name revision)) (cxml:with-element "t:baseNameString" (cxml:text (if (slot-boundp name 'charvalue) (charvalue name) ""))) - (when (variants name) - (map 'list #'to-elem-xtm1.0 (variants name))))) + (when (variants name :revision revision) + (map 'list #'(lambda(x) + (to-elem-xtm1.0 x revision)) + (variants name :revision revision))))) -(defmethod to-elem-xtm1.0 ((occurrence OccurrenceC)) +(defmethod to-elem-xtm1.0 ((occurrence OccurrenceC) revision) "occurrence = element occurrence { instanceOf?, scope?, (resourceRef | resourceData) }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:occurrence" - (to-reifier-elem-xtm1.0 occurrence) - (when (instance-of occurrence) - (to-instanceOf-elem-xtm1.0 (instance-of occurrence))) - (when (themes occurrence) - (to-scope-elem-xtm1.0 occurrence)) - (to-resourceX-elem-xtm1.0 occurrence))) + (to-reifier-elem-xtm1.0 occurrence revision) + (when (instance-of occurrence :revision revision) + (to-instanceOf-elem-xtm1.0 (instance-of occurrence :revision revision) + revision)) + (when (themes occurrence :revision revision) + (to-scope-elem-xtm1.0 occurrence revision)) + (to-resourceX-elem-xtm1.0 occurrence revision))) -(defmethod to-elem-xtm1.0 ((topic TopicC)) +(defmethod to-elem-xtm1.0 ((topic TopicC) revision) "topic = element topic { id, instanceOf*, subjectIdentity, (baseName | occurrence)* }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) - (when (list-instanceOf topic :tm *export-tm*) - (map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic :tm *export-tm*))) - (when (or (psis topic) (locators topic)) - (to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic)))) - (when (names topic) - (map 'list #'to-elem-xtm1.0 (names topic))) - (when (occurrences topic) - (map 'list #'to-elem-xtm1.0 (occurrences topic))))) + (cxml:attribute "id" (topic-id topic revision)) + (let ((ios (list-instanceOf topic :tm *export-tm* :revision revision))) + (when ios + (map 'list #'(lambda(x) + (to-instanceOf-elem-xtm1.0 x revision)) + ios))) + (let ((t-psis (psis topic :revision revision)) + (first-locator (when (locators topic :revision revision) + (first (locators topic :revision revision))))) + (when (or t-psis first-locator) + (to-subjectIdentity-elem-xtm1.0 t-psis first-locator revision))) + (when (names topic :revision revision) + (map 'list #'(lambda(x) + (to-elem-xtm1.0 x revision)) + (names topic :revision revision))) + (when (occurrences topic :revision revision) + (map 'list #'(lambda(x) + (to-elem-xtm1.0 x revision)) + (occurrences topic :revision revision))))) -(defun to-roleSpec-elem-xtm1.0 (topic) +(defun to-roleSpec-elem-xtm1.0 (topic revision) "roleSpec = element roleSpec { topicRef | subjectIndicatorRef }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:roleSpec" - (to-topicRef-elem-xtm1.0 topic))) + (to-topicRef-elem-xtm1.0 topic revision))) -(defmethod to-elem-xtm1.0 ((role RoleC)) +(defmethod to-elem-xtm1.0 ((role RoleC) revision) "member = element member { roleSpec?, (topicRef | resourceRef | subjectIndicatorRef)+ }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:member" - (to-reifier-elem-xtm1.0 role) - (when (instance-of role) - (to-roleSpec-elem-xtm1.0 (instance-of role))) - (to-topicRef-elem-xtm1.0 (player role)))) + (to-reifier-elem-xtm1.0 role revision) + (when (instance-of role :revision revision) + (to-roleSpec-elem-xtm1.0 (instance-of role :revision revision) revision)) + (to-topicRef-elem-xtm1.0 (player role :revision revision) revision))) -(defmethod to-elem-xtm1.0 ((association AssociationC)) +(defmethod to-elem-xtm1.0 ((association AssociationC) revision) "association = element association { instanceOf?, scope?, member+ }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:association" - (to-reifier-elem-xtm1.0 association) - (when (instance-of association) - (to-instanceOf-elem-xtm1.0 (instance-of association))) - (when (themes association) - (to-scope-elem-xtm1.0 association)) - (map 'list #'to-elem-xtm1.0 (roles association)))) + (to-reifier-elem-xtm1.0 association revision) + (when (instance-of association :revision revision) + (to-instanceOf-elem-xtm1.0 (instance-of association :revision revision) revision)) + (when (themes association :revision revision) + (to-scope-elem-xtm1.0 association revision)) + (map 'list #'(lambda(x) + (to-elem-xtm1.0 x revision)) + (roles association :revision revision)))) -(defun to-stub-elem-xtm1.0 (topic) +(defun to-stub-elem-xtm1.0 (topic revision) "transforms a TopicC object to a topic stub element with a topicid, psis and subjectLocators" - (declare (TopicC topic)) + (declare (TopicC topic) + (type (or integer nil) revision)) (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) - (to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic))))) + (cxml:attribute "id" (topic-id topic revision)) + (to-subjectIdentity-elem-xtm1.0 (psis topic :revision revision) + (when (locators topic :revision revision) + (first (locators topic :revision revision))) + revision))) -(defmethod to-elem-xtm1.0 ((fragment FragmentC)) +(defmethod to-elem-xtm1.0 ((fragment FragmentC) revision) "transforms all sub-elements of the passed FragmentC instance" - (to-elem-xtm1.0 (topic fragment)) - (map 'list #'to-stub-elem-xtm1.0 (referenced-topics fragment)) - (map 'list #'to-elem-xtm1.0 (associations fragment))) + (declare (type (or integer nil) revision)) + (to-elem-xtm1.0 (topic fragment) revision) + (map 'list #'(lambda(x) + (to-stub-elem-xtm1.0 x revision)) + (referenced-topics fragment)) + (map 'list #'(lambda(x) + (to-elem-xtm1.0 x revision)) + (associations fragment))) Modified: trunk/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm2.0.lisp Sun Oct 10 05:41:19 2010 @@ -9,54 +9,69 @@ (in-package :exporter) -(defun to-reifier-elem (reifiable-construct) +(defun to-reifier-elem (reifiable-construct revision) "Exports the reifier-attribute. The attribute is only exported if the reifier-topic contains at least one item-identifier." - (declare (ReifiableConstructC reifiable-construct)) - (when (and (reifier reifiable-construct) - (item-identifiers (reifier reifiable-construct))) + (declare (ReifiableConstructC reifiable-construct) + (type (or integer nil) revision)) + (when (and (reifier reifiable-construct :revision revision) + (item-identifiers (reifier reifiable-construct :revision revision) + :revision revision)) (cxml:attribute "reifier" - (uri (first (item-identifiers (reifier reifiable-construct))))))) - -(defun ref-to-elem (topic) - (declare (TopicC topic)) + (uri (first (item-identifiers (reifier reifiable-construct + :revision revision) + :revision revision)))))) + +(defun ref-to-elem (topic revision) + (declare (TopicC topic) + (type (or integer nil) revision)) (cxml:with-element "t:topicRef" ;;TODO: this is pretty much of a hack that works only for local ;;references (cxml:attribute "href" - (format nil "#~a" (topicid topic))))) + (format nil "#~a" (topic-id topic revision))))) + -(defgeneric to-elem (instance) +(defgeneric to-elem (instance revision) (:documentation "converts the Topic Maps construct instance to an XTM 2.0 element")) -(defmethod to-elem ((psi PersistentIdC)) + +(defmethod to-elem ((psi PersistentIdC) revision) + (declare (ignorable revision)) (cxml:with-element "t:subjectIdentifier" (cxml:attribute "href" (uri psi)))) -(defmethod to-elem ((name NameC)) +(defmethod to-elem ((name NameC) revision) "name = element name { reifiable, type?, scope?, value, variant* }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:name" - (to-reifier-elem name) - (map 'list #'to-elem (item-identifiers name)) - (when (slot-boundp name 'instance-of) + (to-reifier-elem name revision) + (map 'list #'(lambda(x) + (to-elem x revision)) + (item-identifiers name :revision revision)) + (when (instance-of name :revision revision) (cxml:with-element "t:type" - (ref-to-elem (instance-of name)))) - (when (themes name) + (ref-to-elem (instance-of name :revision revision) revision))) + (when (themes name :revision revision) (cxml:with-element "t:scope" - (map 'list #'ref-to-elem (themes name)))) + (map 'list #'(lambda(x) + (ref-to-elem x revision)) + (themes name :revision revision)))) (cxml:with-element "t:value" (cxml:text (if (slot-boundp name 'charvalue) (charvalue name) ""))) - (when (variants name) - (map 'list #'to-elem (variants name))))) + (when (variants name :revision revision) + (map 'list #'(lambda(x) + (to-elem x revision)) + (variants name :revision revision))))) -(defun to-resourceX-elem (characteristic) +(defun to-resourceX-elem (characteristic revision) "returns a resourceData or resourceRef element" (declare (CharacteristicC characteristic)) (let ((characteristic-value @@ -67,14 +82,15 @@ (if (slot-boundp characteristic 'datatype) (datatype characteristic) ""))) - (if (string= characteristic-type "http://www.w3.org/2001/XMLSchema#anyURI") ;-> resourceRef + (if (string= characteristic-type *xml-uri*) ;-> resourceRef (cxml:with-element "t:resourceRef" (let ((ref-topic (when (and (> (length characteristic-value) 0) (eql (elt characteristic-value 0) #\#)) - (get-item-by-id (subseq characteristic-value 1))))) + (get-item-by-id (subseq characteristic-value 1) + :revision revision)))) (cxml:attribute "href" (if ref-topic - (concatenate 'string "#" (topicid ref-topic)) + (concatenate 'string "#" (topic-id ref-topic revision)) characteristic-value)))) (cxml:with-element "t:resourceData" (when (slot-boundp characteristic 'datatype) @@ -82,112 +98,151 @@ (cxml:text characteristic-value))))) -(defmethod to-elem ((variant VariantC)) +(defmethod to-elem ((variant VariantC) revision) "variant = element variant { reifiable, scope, (resourceRef | resourceData) }" (cxml:with-element "t:variant" - (to-reifier-elem variant) - (map 'list #'to-elem (item-identifiers variant)) - (when (themes variant) + (to-reifier-elem variant revision) + (map 'list #'(lambda(x) + (to-elem x revision)) + (item-identifiers variant :revision revision)) + (when (themes variant :revision revision) (cxml:with-element "t:scope" - (map 'list #'ref-to-elem (themes variant)))) - (to-resourceX-elem variant))) + (map 'list #'(lambda(x) + (ref-to-elem x revision)) + (themes variant :revision revision)))) + (to-resourceX-elem variant revision))) -(defmethod to-elem ((ii ItemIdentifierC)) +(defmethod to-elem ((ii ItemIdentifierC) revision) "itemIdentity = element itemIdentity { href }" + (declare (ignorable revision)) (cxml:with-element "t:itemIdentity" (cxml:attribute "href" (uri ii)))) -(defmethod to-elem ((occ OccurrenceC)) +(defmethod to-elem ((occ OccurrenceC) revision) "occurrence = element occurrence { reifiable, type, scope?, (resourceRef | resourceData) }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:occurrence" - (to-reifier-elem occ) - (map 'list #'to-elem (item-identifiers occ)) + (to-reifier-elem occ revision) + (map 'list #'(lambda(x) + (to-elem x revision)) + (item-identifiers occ :revision revision)) (cxml:with-element "t:type" - (ref-to-elem (instance-of occ))) + (ref-to-elem (instance-of occ :revision revision) revision)) (map 'list #'(lambda(x) (cxml:with-element "t:scope" - (ref-to-elem x))) (themes occ)) - (to-resourceX-elem occ))) + (ref-to-elem x revision))) (themes occ :revision revision)) + (to-resourceX-elem occ revision))) -(defmethod to-elem ((locator SubjectLocatorC)) +(defmethod to-elem ((locator SubjectLocatorC) revision) "subjectLocator = element subjectLocator { href }" + (declare (ignorable revision)) (cxml:with-element "t:subjectLocator" (cxml:attribute "href" (uri locator)))) -(defmethod to-elem ((topic TopicC)) +(defmethod to-elem ((topic TopicC) revision) "topic = element topic { id, (itemIdentity | subjectLocator | subjectIdentifier)*, instanceOf?, (name | occurrence)* }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) - (map 'list #'to-elem (item-identifiers topic)) - (map 'list #'to-elem (locators topic)) - (map 'list #'to-elem (psis topic)) - (when (list-instanceOf topic :tm *export-tm*) - (cxml:with-element "t:instanceOf" - (loop for item in (list-instanceOf topic :tm *export-tm*) - do (cxml:with-element "t:topicRef" - (cxml:attribute "href" (concatenate 'string "#" (topicid item))))))) - (map 'list #'to-elem (names topic)) - (map 'list #'to-elem (occurrences topic)))) + (cxml:attribute "id" (topic-id topic revision)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (item-identifiers topic :revision revision)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (locators topic :revision revision)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (psis topic :revision revision)) + (let ((ios (list-instanceOf topic :tm *export-tm* :revision revision))) + (when ios + (cxml:with-element "t:instanceOf" + (loop for item in ios + do (cxml:with-element "t:topicRef" + (cxml:attribute "href" (concatenate 'string "#" (topic-id item revision)))))))) + (map 'list #'(lambda(x) + (to-elem x revision)) + (names topic :revision revision)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (occurrences topic :revision revision)))) -(defun to-stub-elem (topic) +(defun to-stub-elem (topic revision) "transforms a TopicC object to a topic stub element with a topicid, a subjectLocator and an itemIdentity element" - (declare (TopicC topic)) + (declare (TopicC topic) + (type (or nil integer) revision)) (cxml:with-element "t:topic" - (cxml:attribute "id" (topicid topic)) - (map 'list #'to-elem (psis topic)) - (map 'list #'to-elem (item-identifiers topic)) - (map 'list #'to-elem (locators topic)))) + (cxml:attribute "id" (topic-id topic revision)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (psis topic :revision revision)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (item-identifiers topic :revision revision)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (locators topic :revision revision)))) -(defmethod to-elem ((role RoleC)) +(defmethod to-elem ((role RoleC) revision) "role = element role { reifiable, type, topicRef }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:role" - (to-reifier-elem role) - (map 'list #'to-elem (item-identifiers role)) + (to-reifier-elem role revision) + (map 'list #'(lambda(x) + (to-elem x revision)) + (item-identifiers role :revision revision)) (cxml:with-element "t:type" - (ref-to-elem (instance-of role))) - (ref-to-elem (player role)))) + (ref-to-elem (instance-of role) revision)) + (ref-to-elem (player role :revision revision) revision))) -(defmethod to-elem ((assoc AssociationC)) +(defmethod to-elem ((assoc AssociationC) revision) "association = element association { reifiable, type, scope?, role+ }" + (declare (type (or integer nil) revision)) (cxml:with-element "t:association" - (to-reifier-elem assoc) - (map 'list #'to-elem (item-identifiers assoc)) + (to-reifier-elem assoc revision) + (map 'list #'(lambda(x) + (to-elem x revision)) + (item-identifiers assoc :revision revision)) (cxml:with-element "t:type" - (ref-to-elem (instance-of assoc))) - (when (themes assoc) + (ref-to-elem (instance-of assoc :revision revision) revision)) + (when (themes assoc :revision revision) (cxml:with-element "t:scope" - (map 'list #'ref-to-elem (themes assoc)))) - (map 'list #'to-elem (roles assoc)))) - + (map 'list #'(lambda(x) + (ref-to-elem x revision)) + (themes assoc :revision revision)))) + (map 'list #'(lambda(x) + (to-elem x revision)) + (roles assoc :revision revision)))) -(defmethod to-elem ((fragment FragmentC)) +(defmethod to-elem ((fragment FragmentC) revision) "transforms all sub-elements of the passed FragmentC instance" - (to-elem (topic fragment)) - (map 'list #'to-stub-elem (referenced-topics fragment)) - (map 'list #'to-elem (associations fragment))) + (declare (type (or integer nil) revision)) + (to-elem (topic fragment) revision) + (map 'list #'(lambda(x) + (to-stub-elem x revision)) + (referenced-topics fragment)) + (map 'list #'(lambda(x) + (to-elem x revision)) + (associations fragment))) -(defgeneric to-string (construct) +(defgeneric to-string (construct &key revision) (:documentation "Print the string representation of a TM element")) - -(defmethod to-string ((construct TopicMapConstructC)) +(defmethod to-string ((construct TopicMapConstructC) &key (revision *TM-REVISION*)) (cxml:with-xml-output (cxml:make-string-sink :indentation 2 :canonical nil) (cxml:with-namespace ("t" *xtm2.0-ns*) - ;(sb-pcl:class-slots (find-class 'PersistentIdC)) - ;(format t "~a" (length (dom:child-nodes (to-elem construct)))) - (to-elem construct)))) + (to-elem construct revision)))) Modified: trunk/src/xml/xtm/importer.lisp ============================================================================== --- trunk/src/xml/xtm/importer.lisp (original) +++ trunk/src/xml/xtm/importer.lisp Sun Oct 10 05:41:19 2010 @@ -23,7 +23,9 @@ *instance-psi* *XTM2.0-NS* *XTM1.0-NS* - *XTM1.0-XLINK*) + *XTM1.0-XLINK* + *XML-STRING* + *XML-URI*) (:import-from :xml-constants *core_psis.xtm*) (:import-from :xml-tools @@ -94,32 +96,30 @@ (error "cannot handle topicrefs that don't start with #")) (subseq topicref 1))) -(defun get-topicid-by-psi (uri &key (xtm-id d:*current-xtm*)) +(defun get-topicid-by-psi (uri &key (xtm-id d:*current-xtm*) (revision *TM-REVISION*)) (when uri (loop for item in (topic-identifiers - (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri uri))) + (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri uri)) :revision revision) when (string= xtm-id (xtm-id item)) return (uri item)))) + (defmacro with-tm ((revision xtm-id tm-id) &body body) "creates a topic map object called tm and puts it into the local scope" - `(let - ((ii (make-instance 'ItemIdentifierC - :uri ,tm-id - :start-revision ,revision))) - ;(add-to-version-history ii :start-revision ,revision) - (let - ((tm - (make-construct 'TopicMapC - :start-revision ,revision - :xtm-id ,xtm-id - :item-identifiers (list ii)))) + `(let ((ii (make-construct 'ItemIdentifierC + :uri ,tm-id + :start-revision ,revision))) + (let ((tm + (make-construct 'TopicMapC + :start-revision ,revision + :xtm-id ,xtm-id + :item-identifiers (list ii)))) (declare (ItemIdentifierC ii)) (declare (TopicMapC tm)) - ,@body))) - + + (defun init-isidorus (&optional (revision (get-revision))) "Initiatlize the database with the stubs of the core topics + PSIs defined in the XTM 1.0 spec. This includes a topic that represents the @@ -136,7 +136,7 @@ (let ((top (from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm"))) - (add-to-topicmap tm top))))))) + (add-to-tm tm top))))))) ;TODO: replace the two importers with this macro (defmacro importer-mac @@ -172,25 +172,23 @@ (declare (TopicMapC tm)) (let ((associationtype - (get-item-by-psi *type-instance-psi*)) + (get-item-by-psi *type-instance-psi* :revision start-revision)) (roletype1 - (get-item-by-psi *type-psi*)) + (get-item-by-psi *type-psi* :revision start-revision)) (roletype2 - (get-item-by-psi *instance-psi*)) + (get-item-by-psi *instance-psi* :revision start-revision)) (player1 (get-item-by-id topicid-of-supertype :xtm-id xtm-id :revision start-revision))) - (unless (and associationtype roletype1 roletype2) (error "Error in the creation of an instanceof association: core topics are missing")) - (unless player1 (error (make-condition 'missing-reference-error :message "could not find type topic (first player)" :reference topicid-of-supertype))) - (add-to-topicmap + (add-to-tm tm (make-construct 'AssociationC @@ -198,5 +196,9 @@ :themes nil :start-revision start-revision :instance-of associationtype - :roles (list (list :instance-of roletype1 :player player1) - (list :instance-of roletype2 :player player2-obj)))))) + :roles (list (list :start-revision start-revision + :instance-of roletype1 + :player player1) + (list :start-revision start-revision + :instance-of roletype2 + :player player2-obj)))))) Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Sun Oct 10 05:41:19 2010 @@ -9,7 +9,7 @@ (in-package :xml-importer) -(defun get-reifier-topic-xtm1.0 (reifiable-elem) +(defun get-reifier-topic-xtm1.0 (reifiable-elem start-revision) "Returns a reifier topic of the reifiable-element or nil." (declare (dom:element reifiable-elem)) (let ((reifier-uri @@ -21,7 +21,7 @@ (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri (concatenate 'string "#" reifier-uri)))) (when psi - (let ((reifier-topic (identified-construct psi))) + (let ((reifier-topic (identified-construct psi :revision start-revision))) (when reifier-topic reifier-topic))))))) @@ -56,8 +56,8 @@ (let ((data-elem (xpath-single-child-elem-by-qname parent-elem *xtm1.0-ns* "resourceData"))) (declare (dom:element parent-elem)) (if data-elem - "http://www.w3.org/2001/XMLSchema#string" - "http://www.w3.org/2001/XMLSchema#anyURI")))) + *XML-STRING* + *XML-URI*)))) (unless data (error "from-resourceX-elem-xtm1.0: one of resourceRef or resourceData must be set")) (list :data data :type type)))) @@ -68,7 +68,6 @@ variant = element variant { parameters, variantName?, variant* }" (declare (dom:element variant-elem)) (declare (CharacteristicC parent-construct)) ;;parent name or parent variant object - (declare (optimize (debug 3))) (let ((parameters (remove-duplicates (remove-if #'null @@ -76,17 +75,17 @@ (from-parameters-elem-xtm1.0 (xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "parameters") start-revision :xtm-id xtm-id) - (themes parent-construct))))) + (themes parent-construct :revision start-revision))))) (variantName (from-resourceX-elem-xtm1.0 (xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "variantName"))) (parent-name (cond ((typep parent-construct 'NameC) parent-construct) ((typep parent-construct 'VariantC) - (name parent-construct)) + (parent parent-construct)) (t (error "from-variant-elem-xtm1.0: parent-construct is neither NameC nor VariantC")))) - (reifier-topic (get-reifier-topic-xtm1.0 variant-elem))) + (reifier-topic (get-reifier-topic-xtm1.0 variant-elem start-revision))) (unless (and variantName parameters) (error "from-variant-elem-xtm1.0: parameters and variantName must be set")) (let ((variant (make-construct 'VariantC @@ -95,7 +94,7 @@ :charvalue (getf variantName :data) :datatype (getf variantName :type) :reifier reifier-topic - :name parent-name))) + :parent parent-name))) (let ((inner-variants (map 'list #'(lambda(x) (from-variant-elem-xtm1.0 x variant start-revision :xtm-id xtm-id)) @@ -110,15 +109,18 @@ (let ((parameters (let ((topicRefs (map 'list #'from-topicRef-elem-xtm1.0 - (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* "topicRef"))) + (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* + "topicRef"))) (subjectIndicatorRefs (map 'list #'(lambda(x) (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* "subjectIndicatorRef")))) + (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* + "subjectIndicatorRef")))) (let ((topic-list (append (map 'list #'(lambda(x) - (get-item-by-id x :xtm-id xtm-id :revision start-revision)) + (get-item-by-id x :xtm-id xtm-id + :revision start-revision)) topicRefs) (map 'list #'(lambda(x) (get-item-by-psi x :revision start-revision)) @@ -146,16 +148,15 @@ (let ((themes (when (xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "scope") (from-scope-elem-xtm1.0 (xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "scope") - :xtm-id xtm-id))) + start-revision :xtm-id xtm-id))) (baseNameString (xpath-fn-string (xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "baseNameString"))) - (reifier-topic (get-reifier-topic-xtm1.0 baseName-elem))) + (reifier-topic (get-reifier-topic-xtm1.0 baseName-elem start-revision))) (unless baseNameString (error "A baseName must have exactly one baseNameString")) - (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue baseNameString :reifier reifier-topic :themes themes))) @@ -182,41 +183,61 @@ (when parent-elem (let ((instanceOf-elems (xpath-child-elems-by-qname parent-elem *xtm1.0-ns* "instanceOf"))) (when (> (length instanceOf-elems) 0) - (let ((topicRefs (map 'list #'(lambda(x) - (when (xpath-single-child-elem-by-qname x *xtm1.0-ns* "topicRef") - (from-topicRef-elem-xtm1.0 - (xpath-single-child-elem-by-qname x *xtm1.0-ns* "topicRef")))) + (let ((topicRefs + (map 'list #'(lambda(x) + (when (xpath-single-child-elem-by-qname + x *xtm1.0-ns* "topicRef") + (from-topicRef-elem-xtm1.0 + (xpath-single-child-elem-by-qname x *xtm1.0-ns* + "topicRef")))) instanceOf-elems)) - (subjectIndicatorRefs (map 'list #'(lambda(x) - (when (xpath-single-child-elem-by-qname - x *xtm1.0-ns* "subjectIndicatorRef") - (get-xlink-attribute - (xpath-single-child-elem-by-qname - x *xtm1.0-ns* "subjectIndicatorRef") "href"))) - instanceOf-elems))) - (let ((ids (remove-if #'null(append - (map 'list #'(lambda(x) - (get-topicid-by-psi x :xtm-id xtm-id)) - subjectIndicatorRefs) - topicRefs)))) + (subjectIndicatorRefs + (map 'list #'(lambda(x) + (when (xpath-single-child-elem-by-qname + x *xtm1.0-ns* "subjectIndicatorRef") + (get-xlink-attribute + (xpath-single-child-elem-by-qname + x *xtm1.0-ns* "subjectIndicatorRef") "href"))) + instanceOf-elems))) + (let ((ids + (remove-if #'null + (append + (map 'list #'(lambda(x) + (get-topicid-by-psi x :xtm-id xtm-id)) + subjectIndicatorRefs) + topicRefs)))) (declare (dom:element parent-elem)) ids)))))) -(defun from-roleSpec-elem-xtm1.0 (roleSpec-elem &key (xtm-id *current-xtm*)) +(defun from-roleSpec-elem-xtm1.0 (roleSpec-elem start-revision + &key (xtm-id *current-xtm*)) "returns the referenced topic of the roleSpec's topicRef and subjectIndicatorRef element." (when roleSpec-elem - (let ((top-id (when (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* "topicRef") - (from-topicRef-elem-xtm1.0 - (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* "topicRef")))) - (sIRs (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id)) + (let ((top-id + (when (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* + "topicRef") + (from-topicRef-elem-xtm1.0 + (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* + "topicRef")))) + (sIRs (map 'list #'(lambda(uri) + (get-topicid-by-psi uri :xtm-id xtm-id + :revision start-revision)) (map 'list #'(lambda(x) (dom:get-attribute-ns x *xtm1.0-xlink* "href")) - (xpath-child-elems-by-qname roleSpec-elem *xtm1.0-ns* "subjectIndicatorRef"))))) - (let ((ref-topic (first (remove-if #'null - (append - (list (get-item-by-id top-id :xtm-id xtm-id)) - (map 'list #'(lambda(id)(get-item-by-id id :xtm-id xtm-id)) sIRs)))))) + (xpath-child-elems-by-qname roleSpec-elem *xtm1.0-ns* + "subjectIndicatorRef"))))) + (let ((ref-topic + (first (remove-if #'null + (append + (when top-id + (list (get-item-by-id top-id :xtm-id xtm-id + :revision start-revision))) + (map 'list #'(lambda(id) + (get-item-by-id + id :xtm-id xtm-id + :revision start-revision)) + sIRs)))))) (declare (dom:element roleSpec-elem)) (unless ref-topic (error (make-condition 'missing-reference-error @@ -224,21 +245,26 @@ ref-topic)))) -(defun from-scope-elem-xtm1.0 (scope-elem &key (xtm-id *current-xtm*)) +(defun from-scope-elem-xtm1.0 (scope-elem start-revision &key (xtm-id *current-xtm*)) "returns the topics referenced by this scope element. the nested elements resourceRef and subjectIndicatorRef are ignored" (when scope-elem (when (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "topicRef") (let ((refs (append (map 'list #'from-topicRef-elem-xtm1.0 - (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "topicRef")) + (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* + "topicRef")) (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id)) (map 'list #'(lambda(x) - (dom:get-attribute-ns x *xtm1.0-xlink* "href")) - (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "subjectIndicatorRef")))))) + (dom:get-attribute-ns x *xtm1.0-xlink* + "href")) + (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* + "subjectIndicatorRef")))))) (let ((ref-topics (map 'list #'(lambda(x) - (let ((ref-topic (get-item-by-id x :xtm-id xtm-id))) + (let ((ref-topic + (get-item-by-id x :xtm-id xtm-id + :revision start-revision))) (if ref-topic ref-topic (error (make-condition 'missing-reference-error @@ -258,21 +284,26 @@ (declare (integer start-revision)) (let* ((instanceOf (when (get-instanceOf-refs-xtm1.0 occ-elem :xtm-id xtm-id) - (get-item-by-id (first (get-instanceOf-refs-xtm1.0 occ-elem :xtm-id xtm-id)) :xtm-id xtm-id))) + (get-item-by-id + (first (get-instanceOf-refs-xtm1.0 occ-elem + :xtm-id xtm-id)) + :xtm-id xtm-id :revision start-revision))) (themes (from-scope-elem-xtm1.0 (xpath-single-child-elem-by-qname occ-elem *xtm1.0-ns* "scope") - :xtm-id xtm-id)) + start-revision :xtm-id xtm-id)) (occurrence-value (from-resourceX-elem-xtm1.0 occ-elem)) - (reifier-topic (get-reifier-topic-xtm1.0 occ-elem))) + (reifier-topic (get-reifier-topic-xtm1.0 occ-elem start-revision))) (unless occurrence-value (error "from-occurrence-elem-xtm1.0: one of resourceRef and resourceData must be set")) (unless instanceOf - (format t "from-occurrence-elem-xtm1.0: type is missing -> http://psi.topicmaps.org/iso13250/model/type-instance~%") - (setf instanceOf (get-item-by-id "type-instance" :xtm-id "core.xtm"))) + (format t "from-occurrence-elem-xtm1.0: type is missing -> ~a~%" + *type-instance-psi*) + (setf instanceOf (get-item-by-psi *type-instance-psi* + :revision start-revision))) (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes themes :instance-of instanceOf :charvalue (getf occurrence-value :data) @@ -283,60 +314,75 @@ (defun from-subjectIdentity-elem-xtm1.0 (subjectIdentity-elem start-revision) "creates PersistentIdC's from the element subjectIdentity" (when subjectIdentity-elem - (let ((psi-refs (map 'list #'(lambda(x) - (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* "subjectIndicatorRef"))) - (locator-refs (map 'list #'(lambda(x) - (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* "resourceRef")))) - - (let ((psis (map 'list #'(lambda(uri) - (let ((id (make-instance 'PersistentIdC - :uri uri - :start-revision start-revision))) - ;(add-to-version-history id :start-revision start-revision) - id)) - psi-refs)) - (locators (map 'list #'(lambda(uri) - (let ((loc (make-instance 'SubjectLocatorC - :uri uri - :start-revision start-revision))) - ;(add-to-version-history loc :start-revision start-revision) - loc)) + (let ((psi-refs + (map 'list #'(lambda(x) + (get-xlink-attribute x "href")) + (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* + "subjectIndicatorRef"))) + (locator-refs + (map 'list #'(lambda(x) + (get-xlink-attribute x "href")) + (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* + "resourceRef")))) + (let ((psis + (map 'list #'(lambda(uri) + (let ((id + (make-construct 'PersistentIdC + :uri uri + :start-revision start-revision))) + id)) + psi-refs)) + (locators (map 'list + #'(lambda(uri) + (let ((loc + (make-construct 'SubjectLocatorC + :uri uri + :start-revision start-revision))) + loc)) locator-refs))) (declare (dom:element subjectIdentity-elem)) (declare (integer start-revision)) (list :psis psis :locators locators))))) -(defun from-member-elem-xtm1.0 (member-elem &key (xtm-id *current-xtm*)) +(defun from-member-elem-xtm1.0 (member-elem start-revision + &key (xtm-id *current-xtm*)) "returns a list with the role- type, player and itemIdentities" (when member-elem (elephant:ensure-transaction (:txn-nosync t) - (let - ((type (from-rolespec-elem-xtm1.0 (xpath-single-child-elem-by-qname member-elem *xtm1.0-ns* "roleSpec") :xtm-id xtm-id)) - (player (remove-if #'null - (append - (list (get-item-by-id (from-topicRef-elem-xtm1.0 - (xpath-single-child-elem-by-qname - member-elem - *xtm1.0-ns* - "topicRef")) - :xtm-id xtm-id)) - (map 'list #'(lambda(topicid) - (get-item-by-id topicid :xtm-id xtm-id)) - (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id)) - (map 'list #'(lambda(x) - (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname - member-elem - *xtm1.0-ns* - "subjectIndicatorRef"))))))) - (reifier-topic (get-reifier-topic-xtm1.0 member-elem))) + (let ((type (from-roleSpec-elem-xtm1.0 + (xpath-single-child-elem-by-qname member-elem *xtm1.0-ns* + "roleSpec") + start-revision :xtm-id xtm-id)) + (player + (let ((topicRef + (from-topicRef-elem-xtm1.0 (xpath-single-child-elem-by-qname + member-elem *xtm1.0-ns* "topicRef"))) + (sIRs (xpath-child-elems-by-qname + member-elem *xtm1.0-ns* "subjectIndicatorRef"))) + (remove-if + #'null + (append + (when topicRef + (list (get-item-by-id topicRef + :xtm-id xtm-id + :revision start-revision))) + (map 'list #'(lambda(topicid) + (get-item-by-id + topicid + :xtm-id xtm-id + :revision start-revision)) + (map 'list #'(lambda(uri) + (get-topicid-by-psi uri :xtm-id xtm-id)) + (map 'list #'(lambda(x) + (get-xlink-attribute x "href")) + sIRs))))))) + (reifier-topic (get-reifier-topic-xtm1.0 member-elem start-revision))) (declare (dom:element member-elem)) (unless player ; if no type is given a standard type will be assigend later in from-assoc... (error "from-member-elem-xtm1.0: missing player in role")) - (list :instance-of type + (list :start-revision start-revision + :instance-of type :player (first player) :item-identifiers nil :reifier reifier-topic))))) @@ -347,19 +393,22 @@ (xtm-id *current-xtm*)) "creates a TopicC instance with a start-revision, all psis, the topicid and the xtm-id" (declare (dom:element topic-elem)) - (declare (integer start-revision)) - ;(declare (optimize (debug 3))) + (declare (integer start-revision)) (elephant:ensure-transaction (:txn-nosync t) - (let ((identifiers (from-subjectIdentity-elem-xtm1.0 (xpath-single-child-elem-by-qname - topic-elem - *xtm1.0-ns* - "subjectIdentity") - start-revision))) + (let ((identifiers (from-subjectIdentity-elem-xtm1.0 + (xpath-single-child-elem-by-qname + topic-elem + *xtm1.0-ns* + "subjectIdentity") + start-revision)) + (topic-identifiers + (list (make-construct 'TopicIdentificationC + :uri (get-topic-id-xtm1.0 topic-elem) + :xtm-id xtm-id)))) (make-construct 'TopicC :start-revision start-revision :psis (getf identifiers :psis) :locators (getf identifiers :locators) - :topicid (get-topic-id-xtm1.0 topic-elem) - :xtm-id xtm-id)))) + :topic-identifiers topic-identifiers)))) (defun merge-topic-elem-xtm1.0 (topic-elem start-revision @@ -372,16 +421,20 @@ (declare (integer start-revision)) (declare (TopicMapC tm)) (elephant:ensure-transaction (:txn-nosync t) - (let - ((top - (get-item-by-id - (get-topic-id-xtm1.0 topic-elem) - :xtm-id xtm-id :revision start-revision)) - (instanceOf-topicRefs (remove-if #'null (get-instanceOf-refs-xtm1.0 topic-elem :xtm-id xtm-id))) - (baseName-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "baseName")) - (occ-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "occurrence"))) + (let ((top + (get-item-by-id + (get-topic-id-xtm1.0 topic-elem) + :xtm-id xtm-id :revision start-revision)) + (instanceOf-topicRefs + (remove-if #'null (get-instanceOf-refs-xtm1.0 topic-elem + :xtm-id xtm-id))) + (baseName-elems + (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "baseName")) + (occ-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "occurrence"))) (unless top - (error "topic ~a could not be found" (get-attribute topic-elem "id"))) + (error (make-condition 'missing-reference-error + :message (format nil "topic ~a could not be found" + (get-attribute topic-elem "id"))))) ;;names (map 'list #'(lambda(x) (from-baseName-elem-xtm1.0 x top start-revision :xtm-id xtm-id)) @@ -392,45 +445,49 @@ occ-elems) ;;instanceOf (dolist (instanceOf-topicRef instanceOf-topicRefs) - (create-instanceof-association instanceOf-topicRef top start-revision :xtm-id xtm-id - :tm tm)) - (add-to-topicmap tm top)))) + (create-instanceof-association instanceOf-topicRef top start-revision + :xtm-id xtm-id :tm tm)) + (add-to-tm tm top)))) -(defun from-association-elem-xtm1.0 (assoc-elem start-revision &key tm (xtm-id *current-xtm*)) +(defun from-association-elem-xtm1.0 (assoc-elem start-revision + &key tm (xtm-id *current-xtm*)) (declare (dom:element assoc-elem)) (declare (integer start-revision)) (declare (TopicMapC tm)) (elephant:ensure-transaction (:txn-nosync t) (let ((type (when (get-instanceOf-refs-xtm1.0 assoc-elem :xtm-id xtm-id) - (get-item-by-id (first (get-instanceOf-refs-xtm1.0 assoc-elem :xtm-id xtm-id)) :xtm-id xtm-id))) + (get-item-by-id (first (get-instanceOf-refs-xtm1.0 assoc-elem + :xtm-id xtm-id)) + :xtm-id xtm-id + :revision start-revision))) (themes (from-scope-elem-xtm1.0 (xpath-single-child-elem-by-qname assoc-elem *xtm1.0-ns* "scope") - :xtm-id xtm-id)) + start-revision :xtm-id xtm-id)) (roles (map 'list #'(lambda(member-elem) - (from-member-elem-xtm1.0 - member-elem :xtm-id xtm-id)) + (from-member-elem-xtm1.0 member-elem start-revision + :xtm-id xtm-id)) (xpath-child-elems-by-qname assoc-elem *xtm1.0-ns* "member"))) - (reifier-topic (get-reifier-topic-xtm1.0 assoc-elem))) + (reifier-topic (get-reifier-topic-xtm1.0 assoc-elem start-revision))) (unless roles (error "from-association-elem-xtm1.0: roles are missing in association")) - (setf roles (set-standard-role-types roles)) + (setf roles (set-standard-role-types roles start-revision)) (unless type (format t "from-association-elem-xtm1.0: type is missing -> http://www.topicmaps.org/xtm/1.0/core.xtm#association~%") - (setf type (get-item-by-id "association" :xtm-id "core.xtm"))) - (add-to-topicmap tm - (make-construct 'AssociationC - :start-revision start-revision - :instance-of type - :themes themes - :reifier reifier-topic - :roles roles))))) - - + (setf type (get-item-by-id "association" :xtm-id "core.xtm" + :revision start-revision))) + (add-to-tm tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of type + :themes themes + :reifier reifier-topic + :roles roles))))) + -(defun set-standard-role-types (roles) +(defun set-standard-role-types (roles start-revision) "sets the missing role types of the passed roles to the default types." (when roles (let ((empty-roles (loop for role in roles @@ -440,22 +497,25 @@ (let ((is-type (loop for role in roles when (and (getf role :instance-of) (loop for psi in (psis (getf role :instance-of)) - when (string= (uri psi) - "http://psi.topicmaps.org/iso13250/model/type") + when (string= (uri psi) *type-psi*) return t)) return t))) (declare (list roles)) (when (not is-type) (loop for role in roles when (not (getf role :instance-of)) - do (setf (getf role :instance-of) (get-item-by-id "type" :xtm-id "core.xtm")) - (format t "set-standard-role-types: role type is missing -> http://psi.topicmaps.org/iso13250/model/type~%") + do (setf (getf role :instance-of) + (get-item-by-psi *type-psi* :revision start-revision)) + (format t "set-standard-role-types: role type is missing -> ~a~%" + *type-psi*) (return t))) (when (or (> (length empty-roles) 1) (and empty-roles (not is-type))) (loop for role in roles when (not (getf role :instance-of)) - do (setf (getf role :instance-of) (get-item-by-id "instance" :xtm-id "core.xtm")) - (format t "set-standard-role-types: role type is missing -> http://psi.topicmaps.org/iso13250/model/instance~%")))))) + do (setf (getf role :instance-of) + (get-item-by-psi *instance-psi* :revision start-revision)) + (format t "set-standard-role-types: role type is missing -> ~a~%" + *instance-psi*)))))) roles)) Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Sun Oct 10 05:41:19 2010 @@ -9,7 +9,7 @@ (in-package :xml-importer) -(defun get-reifier-topic(reifiable-elem) +(defun get-reifier-topic(reifiable-elem start-revision) "Returns the reifier topic of the reifierable-element or nil." (declare (dom:element reifiable-elem)) (let ((reifier-uri (get-attribute reifiable-elem "reifier")) @@ -19,7 +19,7 @@ (let ((ii (elephant:get-instance-by-value 'd:ItemIdentifierC 'd:uri reifier-uri))) (if ii - (let ((reifier-topic (identified-construct ii))) + (let ((reifier-topic (identified-construct ii :revision start-revision))) (if reifier-topic reifier-topic (error "~aitem-identifier ~a not found" err reifier-uri))) @@ -34,7 +34,7 @@ (declare (dom:element elem)) (declare (integer start-revision)) (let - ((id (make-instance classsymbol + ((id (make-construct classsymbol :uri (get-attribute elem "href") :start-revision start-revision))) id)) @@ -49,7 +49,7 @@ *xtm2.0-ns* elem-name))) -(defun from-type-elem (type-elem &key (xtm-id *current-xtm*)) +(defun from-type-elem (type-elem start-revision &key (xtm-id *current-xtm*)) "Returns the topic that reifies this type or nil if no element is input" ; type = element type { topicRef } @@ -62,7 +62,7 @@ (xpath-single-child-elem-by-qname type-elem *xtm2.0-ns* "topicRef"))) - (top (get-item-by-id topicid :xtm-id xtm-id))) + (top (get-item-by-id topicid :xtm-id xtm-id :revision start-revision))) (declare (dom:element type-elem)) (unless top (error (make-condition 'missing-reference-error @@ -70,7 +70,7 @@ top))) -(defun from-scope-elem (scope-elem &key (xtm-id *current-xtm*)) +(defun from-scope-elem (scope-elem start-revision &key (xtm-id *current-xtm*)) "Generate set of themes (= topics) from this scope element and return that set. If the input is nil, the list of themes is empty scope = element scope { topicRef+ }" @@ -89,15 +89,14 @@ (lambda (topicid) (let ((top - (get-item-by-id - topicid :xtm-id xtm-id))) + (get-item-by-id topicid :xtm-id xtm-id + :revision start-revision))) (if top top (error (make-condition 'missing-reference-error :message (format nil "from-scope-elem: could not resolve reference ~a" topicid)))))) topicrefs))) (declare (dom:element scope-elem)) - (unless (>= (length tops) 1) (error "need at least one topic in a scope")) tops))) @@ -121,19 +120,18 @@ (themes (from-scope-elem (xpath-single-child-elem-by-qname - name-elem - *xtm2.0-ns* "scope") :xtm-id xtm-id)) + name-elem *xtm2.0-ns* "scope") + start-revision :xtm-id xtm-id)) (instance-of (from-type-elem (xpath-single-child-elem-by-qname name-elem - *xtm2.0-ns* "type") :xtm-id xtm-id)) - (reifier-topic (get-reifier-topic name-elem))) + *xtm2.0-ns* "type") start-revision :xtm-id xtm-id)) + (reifier-topic (get-reifier-topic name-elem start-revision))) (unless namevalue (error "A name must have exactly one namevalue")) - (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue namevalue :instance-of instance-of :item-identifiers item-identifiers @@ -188,13 +186,13 @@ ((item-identifiers (make-identifiers 'ItemIdentifierC variant-elem "itemIdentity" start-revision)) ;;all themes of the parent name element are inherited to the variant elements (themes (append - (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope") :xtm-id xtm-id) - (themes name))) + (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope") + start-revision :xtm-id xtm-id) + (themes name :revision start-revision))) (variant-value (from-resourceX-elem variant-elem)) - (reifier-topic (get-reifier-topic variant-elem))) + (reifier-topic (get-reifier-topic variant-elem start-revision))) (unless variant-value (error "VariantC: one of resourceRef and resourceData must be set")) - (make-construct 'VariantC :start-revision start-revision :item-identifiers item-identifiers @@ -202,7 +200,7 @@ :charvalue (getf variant-value :data) :datatype (getf variant-value :type) :reifier reifier-topic - :name name))) + :parent name))) (defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*)) @@ -212,25 +210,23 @@ (declare (dom:element occ-elem)) (declare (TopicC top)) (declare (integer start-revision)) - (let ((themes (from-scope-elem (xpath-single-child-elem-by-qname - occ-elem - *xtm2.0-ns* "scope"))) + occ-elem *xtm2.0-ns* "scope") start-revision :xtm-id xtm-id)) (item-identifiers (make-identifiers 'ItemIdentifierC occ-elem "itemIdentity" start-revision)) (instance-of (from-type-elem (xpath-single-child-elem-by-qname occ-elem - *xtm2.0-ns* "type") :xtm-id xtm-id)) + *xtm2.0-ns* "type") start-revision :xtm-id xtm-id)) (occurrence-value (from-resourceX-elem occ-elem)) - (reifier-topic (get-reifier-topic occ-elem))) + (reifier-topic (get-reifier-topic occ-elem start-revision))) (unless occurrence-value (error "OccurrenceC: one of resourceRef and resourceData must be set")) (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes themes :item-identifiers item-identifiers :instance-of instance-of @@ -248,7 +244,6 @@ applicable" (declare (dom:element topic-elem)) (declare (integer start-revision)) - ;(declare (optimize (debug 3))) (elephant:ensure-transaction (:txn-nosync t) (let ((itemidentifiers @@ -256,32 +251,30 @@ (subjectidentifiers (make-identifiers 'PersistentIdC topic-elem "subjectIdentifier" start-revision)) (subjectlocators - (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision))) + (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision)) + (topic-ids (when (get-attribute topic-elem "id") + (list (make-construct 'TopicIdentificationC + :uri (get-attribute topic-elem "id") + :xtm-id xtm-id))))) (make-construct 'TopicC :start-revision start-revision :item-identifiers itemidentifiers :locators subjectlocators :psis subjectidentifiers - :topicid (get-attribute topic-elem "id") - :xtm-id xtm-id)))) + :topic-identifiers topic-ids)))) (defun merge-topic-elem (topic-elem start-revision - &key - tm - (xtm-id *current-xtm*)) + &key tm (xtm-id *current-xtm*)) "Adds further elements (names, occurrences) and instanceOf associations to the topic" - ;TODO: solve merging through reifying (declare (dom:element topic-elem)) (declare (integer start-revision)) (declare (TopicMapC tm)) - ;(format t "xtm-id: ~a current-xtm: ~a revision: ~a~&" xtm-id *current-xtm* start-revision) (elephant:ensure-transaction (:txn-nosync t) (let ((top ;retrieve the already existing topic stub - (get-item-by-id - (get-attribute topic-elem "id") + (get-item-by-id (get-attribute topic-elem "id") :xtm-id xtm-id :revision start-revision))) (let ((instanceof-topicrefs @@ -292,7 +285,8 @@ '((*xtm2.0-ns* "instanceOf") (*xtm2.0-ns* "topicRef")))))) (unless top - (error "topic ~a could not be found" (get-attribute topic-elem "id"))) + (error "topic ~a could not be found (xtm-id: ~a, revision: ~a)" + (get-attribute topic-elem "id") xtm-id start-revision)) (map 'list (lambda (name-elem) @@ -313,7 +307,7 @@ (create-instanceof-association topicref top start-revision :tm tm :xtm-id xtm-id)) - (add-to-topicmap tm top) + (add-to-tm tm top) top)))) @@ -330,24 +324,22 @@ (instance-of (from-type-elem (xpath-single-child-elem-by-qname - role-elem - *xtm2.0-ns* - "type") :xtm-id xtm-id)) + role-elem *xtm2.0-ns* "type") + start-revision :xtm-id xtm-id)) (player - (get-item-by-id - (get-topicref-uri - (xpath-single-child-elem-by-qname - role-elem - *xtm2.0-ns* - "topicRef")) :xtm-id xtm-id)) - (reifier-topic (get-reifier-topic role-elem))) + (get-item-by-id (get-topicref-uri + (xpath-single-child-elem-by-qname + role-elem *xtm2.0-ns* "topicRef")) + :xtm-id xtm-id :revision start-revision)) + (reifier-topic (get-reifier-topic role-elem start-revision))) (unless player ;instance-of will be set later - if there is no one (error "Role in association with topicref ~a not complete" (get-topicref-uri (xpath-single-child-elem-by-qname role-elem *xtm2.0-ns* "topicRef")))) - (list :reifier reifier-topic + (list :start-revision start-revision + :reifier reifier-topic :instance-of instance-of :player player :item-identifiers item-identifiers)))) @@ -363,19 +355,18 @@ (declare (integer start-revision)) (declare (TopicMapC tm)) (elephant:ensure-transaction (:txn-nosync t) - (let - ((item-identifiers + (let + ((item-identifiers (make-identifiers 'ItemIdentifierC assoc-elem "itemIdentity" start-revision)) (instance-of (from-type-elem (xpath-single-child-elem-by-qname - assoc-elem - *xtm2.0-ns* "type") :xtm-id xtm-id)) + assoc-elem *xtm2.0-ns* "type") + start-revision :xtm-id xtm-id)) (themes (from-scope-elem - (xpath-single-child-elem-by-qname - assoc-elem - *xtm2.0-ns* "scope"))) + (xpath-single-child-elem-by-qname assoc-elem *xtm2.0-ns* "scope") + start-revision :xtm-id xtm-id)) (roles ;a list of tuples (map 'list (lambda @@ -384,9 +375,9 @@ (xpath-child-elems-by-qname assoc-elem *xtm2.0-ns* "role"))) - (reifier-topic (get-reifier-topic assoc-elem))) - (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them - (add-to-topicmap + (reifier-topic (get-reifier-topic assoc-elem start-revision))) + (setf roles (set-standard-role-types roles start-revision)); sets standard role types if there are missing some of them + (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -415,7 +406,7 @@ (let ((topic-vector (get-topic-elems xtm-dom))) (loop for top-elem across topic-vector do - (add-to-topicmap + (add-to-tm tm (from-topic-elem-to-stub top-elem revision :xtm-id xtm-id)))))) Modified: trunk/src/xml/xtm/setup.lisp ============================================================================== --- trunk/src/xml/xtm/setup.lisp (original) +++ trunk/src/xml/xtm/setup.lisp Sun Oct 10 05:41:19 2010 @@ -22,9 +22,9 @@ importer for the XTM version. Does *not* close the store afterwards" (declare ((or pathname string) xtm-path)) (declare ((or pathname string) repository-path)) - (let - ((xtm-dom (dom:document-element (cxml:parse-file - (truename xtm-path) (cxml-dom:make-dom-builder))))) + (let ((xtm-dom (dom:document-element + (cxml:parse-file + (truename xtm-path) (cxml-dom:make-dom-builder))))) (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) @@ -40,7 +40,7 @@ (defun setup-repository (xtm-path repository-path &key - tm-id + (tm-id (error "you must provide a stable identifier (PSI-style) for this TM")) (xtm-id (get-uuid)) (xtm-format '2.0)) "Initializes a repository and imports a XTM file into it" @@ -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] r324 - branches/new-datamodel/src/unit_tests
by Lukas Giessmann 10 Oct '10

10 Oct '10

Author: lgiessmann Date: Sun Oct 10 04:40:18 2010 New Revision: 324 Log: new-datamodel: fixed a bug in the datamodel-unit-test for "get-item-by-psi" Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp 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 Oct 10 04:40:18 2010 @@ -598,27 +598,29 @@ (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-psi-id")) (signals object-not-found-error - (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0)) + (get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0)) (signals object-not-found-error - (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0)) - (is-false (get-item-by-locator "any-psi-id")) + (get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0)) + (is-false (get-item-by-psi "any-psi-id")) (add-psi top-1 psi-3-1 :revision rev-1) (add-psi top-1 psi-3-2 :revision rev-1) + (is-false (get-item-by-locator "psi-3" :revision rev-1)) + (is-false (get-item-by-item-identifier "psi-3" :revision rev-1)) (signals duplicate-identifier-error - (get-item-by-locator "psi-3" :revision rev-1)) + (get-item-by-psi "psi-3" :revision rev-1)) (add-psi top-2 psi-1) (add-psi top-2 psi-2 :revision rev-2) - (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-0))) - (is (eql top-2 (get-item-by-locator "psi-2" :revision rev-0))) - (is (eql top-2 (get-item-by-locator "psi-1" :revision 500))) - (is-false (get-item-by-locator "psi-2" :revision rev-1)) + (is (eql top-2 (get-item-by-psi "psi-1" :revision rev-0))) + (is (eql top-2 (get-item-by-psi "psi-2" :revision rev-0))) + (is (eql top-2 (get-item-by-psi "psi-1" :revision 500))) + (is-false (get-item-by-psi "psi-2" :revision rev-1)) (delete-psi top-2 psi-1 :revision rev-2) - (is-false (get-item-by-locator "psi-1" :revision rev-0)) - (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (is-false (get-item-by-psi "psi-1" :revision rev-0)) + (is (eql top-2 (get-item-by-psi "psi-1" :revision rev-1))) (add-psi top-3 psi-1 :revision rev-2) - (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (is (eql top-2 (get-item-by-psi "psi-1" :revision rev-1))) (d::add-to-version-history top-3 :start-revision rev-2) - (is (eql top-3 (get-item-by-locator "psi-1" :revision rev-0)))))) + (is (eql top-3 (get-item-by-psi "psi-1" :revision rev-0)))))) (test test-ReifiableConstructC ()

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs October 2010