From lgiessmann at common-lisp.net Wed Jul 1 07:32:59 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 01 Jul 2009 03:32:59 -0400 Subject: [isidorus-cvs] r83 - in trunk/src: ajax/javascripts json Message-ID: Author: lgiessmann Date: Wed Jul 1 03:32:59 2009 New Revision: 83 Log: ajax-client: fixed a bug which occured by editing existing topics with more than one PSI - if you selected the placeholder "**current-topic**" the PSIs were transformed to JSON as one long string and not as an array Modified: trunk/src/ajax/javascripts/create.js trunk/src/json/json_importer.lisp Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Wed Jul 1 03:32:59 2009 @@ -133,6 +133,8 @@ // --- if the validation succeeded the fragment will be sent to the server var tPsis = topic.getContent().subjectIdentifiers; + if(!tPsis || tPsis.length === 0) tPsis = "null"; + else tPsis = tPsis.toJSON() var referencedTopics = topic.getReferencedTopics(); if(associations){ referencedTopics = referencedTopics.concat(associations.getReferencedTopics()).without(CURRENT_TOPIC).uniq(); @@ -149,7 +151,7 @@ } var jTopic = "\"topic\":" + topic.toJSON(); var jTopicStubs = "\"topicStubs\":" + tsStr; - var jAssociations = "\"associations\":" + (associations ? associations.toJSON().gsub(CURRENT_TOPIC_ESCAPED, tPsis) : "null"); + var jAssociations = "\"associations\":" + (associations ? associations.toJSON().gsub("\\[\"" + CURRENT_TOPIC_ESCAPED + "\"\\]", tPsis) : "null"); var jTmId = "\"tmIds\":" + tmId.toJSON(); var json = "{" + jTopic + "," + jTopicStubs + "," + jAssociations + "," + jTmId + "}"; commitFragment(json, function(xhr){ alert("The fragment was committed succesfully!"); }, null); Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Wed Jul 1 03:32:59 2009 @@ -217,6 +217,7 @@ '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))))) (unless top From lgiessmann at common-lisp.net Fri Jul 3 21:21:49 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 03 Jul 2009 17:21:49 -0400 Subject: [isidorus-cvs] r84 - in trunk/src: ajax/javascripts model rest_interface unit_tests Message-ID: Author: lgiessmann Date: Fri Jul 3 17:21:46 2009 New Revision: 84 Log: json-server: fixed a problem with requesting the latest fragment of a given topic-psi -> now there will be searched or created REALLY the LATEST fragment Modified: trunk/src/ajax/javascripts/edit.js trunk/src/ajax/javascripts/requests.js trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/json_test.lisp Modified: trunk/src/ajax/javascripts/edit.js ============================================================================== --- trunk/src/ajax/javascripts/edit.js (original) +++ trunk/src/ajax/javascripts/edit.js Fri Jul 3 17:21:46 2009 @@ -53,7 +53,7 @@ liTopicSelect.insert({"bottom" : err}); } else { - if(!psi || psi.strip().lenght === 0) psi = null; + if(!psi || psi.strip().length === 0) psi = null; edit = new EditC(json.flatten().sort(), innerMakeFragment, psi); liTopicSelect.insert({"bottom" : edit.getFrame()}); } Modified: trunk/src/ajax/javascripts/requests.js ============================================================================== --- trunk/src/ajax/javascripts/requests.js (original) +++ trunk/src/ajax/javascripts/requests.js Fri Jul 3 17:21:46 2009 @@ -161,7 +161,7 @@ else topicStubs.push(xhr.responseText); }, "onFailure" : function(xhr){ - alert("From getTopicStubs(): Could not equest topicStub information for \"" + xhr.request.url + "\"!!!"); + alert("From getTopicStubs(): Could not request topicStub information for \"" + xhr.request.url + "\"!!!"); onFailureHandler(); }}); } Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp (original) +++ trunk/src/model/changes.lisp Fri Jul 3 17:21:46 2009 @@ -270,29 +270,27 @@ (find-associations-for-topic top))) -(defun get-latest-fragment-of-topic (topic-psi) +(defun create-latest-fragment-of-topic (topic-psi) "returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) - (let ((topic-psi topic-psi)) - (let ((psi - (elephant:get-instance-by-value 'PersistentIdC 'uri topic-psi))) - (when psi - (let ((topic - (identified-construct psi))) - (when topic - (loop for current-revision in (versions topic) - do (get-fragments (start-revision current-revision))) - (let ((fragments - (elephant:get-instances-by-value 'FragmentC 'topic topic))) - ;; maybe there are more fragments of this topic in different revisions, - ;; so we need to search the fragment with a certain revision - (let ((found-fragment - (if fragments - (first (sort fragments #'> :key 'revision)) - ;; if there exist a topic but always no fragment, there will be generated a new fragment of the latest version for the searched topic - (make-instance 'FragmentC - :revision (first (sort (versions topic) #'> :key 'start-revision)) - :associations (find-associations-for-topic topic) - :referenced-topics (find-referenced-topics topic) - :topic topic)))) - found-fragment)))))))) \ No newline at end of file + (let ((topic + (get-item-by-psi topic-psi))) + (when topic + (let ((start-revision + (start-revision + (find-if #'(lambda(x) + (when (= 0 (end-revision x)) + t)) + (versions topic))))) + (let ((existing-fragment + (find-if #'(lambda(x) + (when (eq topic (topic x)) + t)) + (get-fragments start-revision)))) + (if existing-fragment + existing-fragment + (make-instance 'FragmentC + :revision start-revision + :associations (find-associations-for-topic topic) + :referenced-topics (find-referenced-topics topic) + :topic topic))))))) \ No newline at end of file Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri Jul 3 17:21:46 2009 @@ -99,7 +99,7 @@ :used-as-theme :variants :xor - :get-latest-fragment-of-topic + :create-latest-fragment-of-topic :*current-xtm* ;; special variables :*TM-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 Fri Jul 3 17:21:46 2009 @@ -216,7 +216,7 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (get-latest-fragment-of-topic identifier))) + (create-latest-fragment-of-topic identifier))) (if fragment (handler-case (to-json-string fragment) (condition (err) Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Fri Jul 3 17:21:46 2009 @@ -131,10 +131,10 @@ (elephant:open-store (xml-importer:get-store-spec dir)) (let ((frag-t100 - (get-latest-fragment-of-topic + (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadata")) (frag-topic - (get-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#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\"]}")) (frag-topic-string @@ -155,7 +155,7 @@ (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj - (get-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) + (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) (to-json-string fragment-obj)))) (let ((fragment-list (json-importer::get-fragment-values-from-json-list From lgiessmann at common-lisp.net Sat Jul 4 10:54:10 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sat, 04 Jul 2009 06:54:10 -0400 Subject: [isidorus-cvs] r85 - trunk/src/json Message-ID: Author: lgiessmann Date: Sat Jul 4 06:54:10 2009 New Revision: 85 Log: json-server: fixed a bug with collecting constraint topics for a give topic-type or topic-instance Modified: trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_validation.lisp Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Sat Jul 4 06:54:10 2009 @@ -991,8 +991,24 @@ (let ((akos-and-isas-of-this (remove-duplicates (if (eql treat-as 'type) - (topictype-p topic-instance) - (valid-instance-p topic-instance))))) + (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) @@ -1068,8 +1084,9 @@ (defun get-all-constraint-topics-of-association(associationtype-topic) "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*)) (let ((akos-and-isas-of-this - (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (is-type-constrained :what *associationtype-constraint-psi*)))) + (get-all-upper-constrainted-topics associationtype-topic))) (let ((all-associationrole-constraints nil) (all-roleplayer-constraints nil) (all-otherrole-constraints nil)) Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Sat Jul 4 06:54:10 2009 @@ -420,4 +420,31 @@ (remove-if #'(lambda(x) (when (eql topictype-constraint x) t)) (get-direct-instances-of-topic topictype-constraint)))))) - ttc)))) \ No newline at end of file + ttc)))) + + +(defun list-all-supertypes (topic-instance &optional (checked-topics nil)) + "Returns all supertypes of the given topic recursively." + (let ((current-checked-topics (append checked-topics (list topic-instance))) + (akos-of-this (get-direct-supertypes-of-topic topic-instance))) + (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))) + (dolist (new-topic new-checked-topics) + (pushnew new-topic current-checked-topics))))) + current-checked-topics)) + + +(defun get-all-upper-constrainted-topics (topic) + "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." + ;; find all direct types + (let ((direct-isas-of-this + (get-direct-types-of-topic topic))) + + ;; find all supertypes (recursive -> transitive relationship + (let ((all-akos-of-this + (list-all-supertypes topic))) + (remove-duplicates (union direct-isas-of-this all-akos-of-this))))) \ No newline at end of file From lgiessmann at common-lisp.net Sat Jul 4 14:36:24 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sat, 04 Jul 2009 10:36:24 -0400 Subject: [isidorus-cvs] r86 - trunk/src/ajax/javascripts Message-ID: Author: lgiessmann Date: Sat Jul 4 10:36:21 2009 New Revision: 86 Log: ajax-client: fixed a problem that occurred with firefox after committing an edit or created fragment by changing the occurrent-type, so the datatyp does'nt changed to the corresponding occurrent-type Modified: trunk/src/ajax/javascripts/constants.js trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Sat Jul 4 10:36:21 2009 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = /*"http://143.93.190.237:8000/";*/ "http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Sat Jul 4 10:36:21 2009 @@ -1816,7 +1816,17 @@ var cssTitle = "No constraint found for this occurrence"; if(noConstraint === false) cssTitle = "min: " + _min + " max: " + _max + " regular expression: " + constraint.regexp; this.__cssTitle__ = cssTitle; - makeResource(this, contents, constraint, (occurrenceTypes ? occurrenceTypes[0].datatypeConstraint : null), cssTitle, {"rows" : 5, "cols" : 70}); + + var dataType = null; + if(types && types.length !== 0){ + for(var i = 0; occurrenceTypes && i !== occurrenceTypes.length; ++i){ + if(occurrenceTypes[i].occurrenceType.indexOf(types[0]) !== -1){ + dataType = occurrenceTypes[i].datatypeConstraint; + break; + } + } + } + makeResource(this, contents, constraint, dataType, cssTitle, {"rows" : 5, "cols" : 70}); this.getFrame().observe("dblclick", function(event){ dblClickHandler(owner, event); @@ -4056,7 +4066,8 @@ } if(foundIdx !== -1 && constraints[foundIdx].datatypeConstraint){ var dc = constraints[foundIdx].datatypeConstraint; - myself.__datatype__.__frames__[0].getFrame().select("input")[0].writeAttribute({"readonly" : "readonly", "value" : dc}); + myself.__datatype__.__frames__[0].getFrame().select("input")[0].writeAttribute({"readonly" : "readonly"}); + myself.__datatype__.__frames__[0].getFrame().select("input")[0].setValue(dc); } else { myself.__datatype__.__frames__[0].getFrame().select("input")[0].writeAttribute({"value" : ""}); From lgiessmann at common-lisp.net Sat Jul 4 15:11:50 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sat, 04 Jul 2009 11:11:50 -0400 Subject: [isidorus-cvs] r87 - trunk/src/ajax/javascripts Message-ID: Author: lgiessmann Date: Sat Jul 4 11:11:44 2009 New Revision: 87 Log: ajax-client: fixed a known problem by committing edited fragments - so there won't be requested a topicStub for current fragment's "main"-topic Modified: trunk/src/ajax/javascripts/create.js Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Sat Jul 4 11:11:44 2009 @@ -137,7 +137,17 @@ else tPsis = tPsis.toJSON() var referencedTopics = topic.getReferencedTopics(); if(associations){ - referencedTopics = referencedTopics.concat(associations.getReferencedTopics()).without(CURRENT_TOPIC).uniq(); + var ePsis = null; + if(contents && contents.topic && contents.topic.subjectIdentifiers && contents.topic.subjectIdentifiers.length !== 0){ + ePsis = contents.topic.subjectIdentifiers; + } + + var aStubs = associations.getReferencedTopics(); + if(aStubs && aStubs.length !== 0){ + aStubs = aStubs.without(CURRENT_TOPIC).uniq(); + for(var i = 0; i !== ePsis.length; ++i) aStubs = aStubs.without(ePsis[i]); + } + referencedTopics = referencedTopics.concat(aStubs); } function onSuccessHandler(topicStubs){ var tsStr = "null"; From lgiessmann at common-lisp.net Sat Jul 4 15:33:49 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sat, 04 Jul 2009 11:33:49 -0400 Subject: [isidorus-cvs] r88 - trunk/src/ajax/javascripts Message-ID: Author: lgiessmann Date: Sat Jul 4 11:33:48 2009 New Revision: 88 Log: ajax-client: fixed a bug under safari with the class "SelectrowC" where the default-selected-element wasn't selected. currently there will be additionally set the option selected="selected" to solve this problem Modified: trunk/src/ajax/javascripts/constants.js trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Sat Jul 4 11:33:48 2009 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = "http://192.168.178.21:8000/"; //"http://localhost:8000/"; // of the form "http://(.+)/" var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Sat Jul 4 11:33:48 2009 @@ -158,7 +158,9 @@ this.__content__ = new Element("select"); for(var i = 0; i != contents.length; ++i){ // --- the attribute value must be set for IE - this.__content__.insert({"bottom" : new Element("option", {"value" : contents[i]}).update(contents[i])}); + var opt = new Element("option", {"value" : contents[i]}).update(contents[i]); + this.__content__.insert({"bottom" : opt}); + if(i === 0) opt.writeAttribute({"selected" : "selected"}); } this.__remove__.insert({"after" : this.__content__}); From lgiessmann at common-lisp.net Sat Jul 4 15:49:18 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sat, 04 Jul 2009 11:49:18 -0400 Subject: [isidorus-cvs] r89 - in trunk/src: ajax/javascripts unit_tests Message-ID: Author: lgiessmann Date: Sat Jul 4 11:49:18 2009 New Revision: 89 Log: ajax-client: the test-file poems.xtm was changed to a final state - there are no unused sub-types or any other senseless constructs for testing anymore Modified: trunk/src/ajax/javascripts/constants.js trunk/src/unit_tests/poems.xtm Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Sat Jul 4 11:49:18 2009 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://192.168.178.21:8000/"; //"http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Sat Jul 4 11:49:18 2009 @@ -1,76 +1,5 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - 1 - - - - 2 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1640,45 +1569,6 @@ - - - - - - - - - - - - - - - - - - - - - - - http://www.w3.org/2001/XMLSchema#float - - - - - - - - - - - - - - - - @@ -2547,7 +2437,7 @@ - + Hat der alte Hexenmeister sich doch einmal wegbegeben! Und nun sollen seine Geister @@ -2717,7 +2607,6 @@ - @@ -2731,7 +2620,6 @@ - From lgiessmann at common-lisp.net Wed Jul 8 11:02:06 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 08 Jul 2009 07:02:06 -0400 Subject: [isidorus-cvs] r90 - in trunk: docs src src/ajax/javascripts src/atom src/rest_interface src/threading src/unit_tests src/xml Message-ID: Author: lgiessmann Date: Wed Jul 8 07:02:04 2009 New Revision: 90 Log: isidorus (core): reimplemented the threading module -> all private function of hunchentoot are replaced by public functions of the package bordeaux-threads which is internally used by hunchentoot; the macors with-reader-lock and witrh-writer-lock are mostly used at the "top-layer" of all calls, e.g. RESTful-interface - with one exception the xml-im/exporter. In this module are with locks used in the main import-calls, e.g. init-isidorus, importer-xtm1.0, import-only-topics, importer, export-xtm, export-xtm-to-string and export-xtm-fragment; ajax-client: fixed a problem when creating a associaitons in the section "create topics" Added: trunk/src/unit_tests/threading_test.lisp Modified: trunk/docs/xtm_json.txt trunk/src/ajax/javascripts/create.js trunk/src/ajax/javascripts/home.js trunk/src/atom/atom.lisp trunk/src/atom/fragments.lisp trunk/src/isidorus.asd 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/xml/exporter.lisp trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/exporter_xtm2.0.lisp trunk/src/xml/importer.lisp trunk/src/xml/importer_xtm1.0.lisp trunk/src/xml/importer_xtm2.0.lisp trunk/src/xml/setup.lisp Modified: trunk/docs/xtm_json.txt ============================================================================== --- trunk/docs/xtm_json.txt (original) +++ trunk/docs/xtm_json.txt Wed Jul 8 07:02:04 2009 @@ -390,7 +390,7 @@ //+----------------------------------------------------------------------------- -//+ associationConstraint +//+ associationConstraints //+ The associationConstraint describes how an association of a given type //+ has to be defined. //+ associationRoleTypeConstraint constains all available roletypes for this @@ -441,5 +441,5 @@ //+----------------------------------------------------------------------------- { "topicConstraints" : , - "associationsConstraints" : [ , <...> ] + "associationsConstraints" : [ , <...> ] } Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Wed Jul 8 07:02:04 2009 @@ -145,10 +145,11 @@ var aStubs = associations.getReferencedTopics(); if(aStubs && aStubs.length !== 0){ aStubs = aStubs.without(CURRENT_TOPIC).uniq(); - for(var i = 0; i !== ePsis.length; ++i) aStubs = aStubs.without(ePsis[i]); + for(var i = 0; ePsis && i !== ePsis.length; ++i) aStubs = aStubs.without(ePsis[i]); } referencedTopics = referencedTopics.concat(aStubs); } + function onSuccessHandler(topicStubs){ var tsStr = "null"; if(topicStubs && topicStubs.length !== 0){ Modified: trunk/src/ajax/javascripts/home.js ============================================================================== --- trunk/src/ajax/javascripts/home.js (original) +++ trunk/src/ajax/javascripts/home.js Wed Jul 8 07:02:04 2009 @@ -13,7 +13,7 @@ function makeHome() { var content = new Element("div", {"class" : CLASSES.content()}); - var header = new Element("h1").update("Topic Map Overview"); + var header = new Element("h1").update("Topic Maps Overview"); content.insert({"bottom" : header}); $(CLASSES.subPage()).insert({"bottom" : content}); Modified: trunk/src/atom/atom.lisp ============================================================================== --- trunk/src/atom/atom.lisp (original) +++ trunk/src/atom/atom.lisp Wed Jul 8 07:02:04 2009 @@ -8,7 +8,7 @@ (defpackage :atom - (:use :cl :cxml :constants :xml-tools :datamodel :drakma) + (:use :cl :cxml :constants :xml-tools :datamodel :drakma :isidorus-threading) (:export :collection-feed :defsite :dependency Modified: trunk/src/atom/fragments.lisp ============================================================================== --- trunk/src/atom/fragments.lisp (original) +++ trunk/src/atom/fragments.lisp Wed Jul 8 07:02:04 2009 @@ -35,23 +35,24 @@ "Unlike for the other feed types, entries can be calculated" (remove nil - (loop for fragment in - (mapcan #'d:get-fragments (rest (d:get-all-revisions))) - collect - (let - ((tm (d:get-item-by-item-identifier (tm-id feed) :revision 0)) - (xtm-link (format nil "~a/~a" - (link feed) (d:unique-id fragment))) - (psi (d:uri (first (d:psis (d:topic fragment)))))) - (when (d:in-topicmap tm (d:topic fragment)) - (make-instance 'fragment-entry - :id xtm-link - :title psi - :psi psi - :path (format nil "~a/~a" (path feed) (d:unique-id fragment)) - :updated (datetime-in-iso-format (d:revision fragment)) - :link xtm-link - :summary (format nil "Fragment for topic ~a" psi))))))) + (with-writer-lock + (loop for fragment in + (mapcan #'d:get-fragments (rest (d:get-all-revisions))) + collect + (let + ((tm (d:get-item-by-item-identifier (tm-id feed) :revision 0)) + (xtm-link (format nil "~a/~a" + (link feed) (d:unique-id fragment))) + (psi (d:uri (first (d:psis (d:topic fragment)))))) + (when (d:in-topicmap tm (d:topic fragment)) + (make-instance 'fragment-entry + :id xtm-link + :title psi + :psi psi + :path (format nil "~a/~a" (path feed) (d:unique-id fragment)) + :updated (datetime-in-iso-format (d:revision fragment)) + :link xtm-link + :summary (format nil "Fragment for topic ~a" psi)))))))) ;; (defun build-fragments-feed (tm-id) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Jul 8 07:02:04 2009 @@ -51,7 +51,8 @@ "exporter_xtm2.0"))) :depends-on ("constants" "xml-constants" - "model")) + "model" + "threading")) (:module "atom" :components ((:file "atom") ;; (:file "configuration" @@ -66,7 +67,9 @@ :depends-on ("fragments" "snapshots")) (:file "confreader" :depends-on ("collection" "fragments" "snapshots"))) - :depends-on ("model" "xml")) + :depends-on ("model" + "xml" + "threading")) (:module "rest_interface" :components ((:file "rest-interface") (:file "publish_feeds" @@ -78,7 +81,8 @@ :depends-on ("model" "atom" "xml" - "json")) + "json" + "threading")) (:module "unit_tests" :components ((:static-file "dangling_topicref.xtm") (:static-file "inconsistent.xtm") @@ -119,12 +123,14 @@ (:file "atom_test" :depends-on ("fixtures")) (:file "json_test" - :depends-on ("fixtures"))) + :depends-on ("fixtures")) + (:file "threading_test")) :depends-on ("atom" "constants" "model" "xml" - "json")) + "json" + "threading")) (:module "json" :components ((:file "json_exporter") (:file "json_importer") @@ -133,7 +139,8 @@ (:file "json_tmcl_constants") (:file "json_tmcl" :depends-on ("json_tmcl_validation"))) - :depends-on ("model" "xml")) + :depends-on ("model" + "xml")) (:module "ajax" :components ((:static-file "isidorus.html") (:module "javascripts" @@ -158,9 +165,8 @@ :components ((:static-file "home.css") (:static-file "navi.css") (:static-file "main.css"))))) - ) - ;;(:module "threading" - ;; :components ((:file "reader-writer")))) + (:module "threading" + :components ((:file "reader-writer")))) :depends-on (:cxml :drakma :elephant Modified: trunk/src/rest_interface/publish_feeds.lisp ============================================================================== --- trunk/src/rest_interface/publish_feeds.lisp (original) +++ trunk/src/rest_interface/publish_feeds.lisp Wed Jul 8 07:02:04 2009 @@ -56,7 +56,8 @@ (setf (hunchentoot:content-type*) "application/x-tm+xml;version=1.0; charset=utf-8") (let ((fragment - (d:get-fragment (parse-integer unique-id)))) + (with-reader-lock + (d:get-fragment (parse-integer unique-id))))) (if fragment (exporter:export-xtm-fragment fragment :xtm-format '1.0) (format nil ""))))) Modified: trunk/src/rest_interface/read.lisp ============================================================================== --- trunk/src/rest_interface/read.lisp (original) +++ trunk/src/rest_interface/read.lisp Wed Jul 8 07:02:04 2009 @@ -62,14 +62,14 @@ (revision (d:get-revision))) (loop for entry in (slot-value feed 'atom:entries) do (let - ((top (d:get-item-by-psi (psi entry) :revision revision)) + ((top (d:get-item-by-psi (psi entry) :revision revision)) (xtm-id (atom:id entry)) (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))) (when top - (mark-as-deleted top :source-locator source-locator :revision revision)) + (mark-as-deleted top :source-locator source-locator :revision revision)) ;(format t "Fragment feed: ~a~&" (link entry)) (importer-xtm1.0 (dom:document-element @@ -79,9 +79,9 @@ ;locator + a suitable internal id as an identifier to all ;characteristics and associations that don't already have ;one and then reuse it next time - (add-source-locator - (d:get-item-by-psi (psi entry) :revision revision) ;works even if the topic is only created during import - :source-locator source-locator :revision revision)))))) + (add-source-locator + (d:get-item-by-psi (psi entry) :revision revision) ;works even if the topic is only created during import + :source-locator source-locator :revision revision)))))) (defun string-max (string-list &optional (max nil)) (cond @@ -172,9 +172,10 @@ (get-attribute snapshot-feed-link-elem "href") :tm-id feed-url))) (assert imported-snapshot-entry) - (import-fragments-feed - (get-attribute fragment-feed-link-elem "href") - imported-snapshot-entry :tm-id feed-url)))) + (with-writer-lock + (import-fragments-feed + (get-attribute fragment-feed-link-elem "href") + imported-snapshot-entry :tm-id feed-url))))) \ No newline at end of file Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Wed Jul 8 07:02:04 2009 @@ -17,7 +17,8 @@ :xml-tools :xml-importer :json-exporter - :json-importer) + :json-importer + :isidorus-threading) (:export :import-fragments-feed :import-snapshots-feed :import-tm-feed @@ -56,75 +57,16 @@ (lambda () (apply page-function (coerce matched-registers 'list)))))))) -;; (defun feeds () -;; "interface funtion to the corresponding Atom method" -;; (setf (content-type) "application/atom+xml; charset=UTF-8") -;; (cxml:with-xml-output (cxml:make-string-sink :canonical t) -;; (atom:feed-to-elem atom::*tm-feed*))) - -;; (defun snapshot-feed () -;; "Interface function to the corresponding Atom method" -;; (setf (content-type) "application/atom+xml; charset=UTF-8") -;; (cxml:with-xml-output (cxml:make-string-sink :canonical t) -;; ;(atom:build-snapshot-feed))) -;; )) - -;; (defun snapshots (&optional revision) -;; "Export a snapshot by revision" -;; (assert revision) -;; (format t "in snapshots~&") -;; (setf (content-type) "application/xtm+xml; charset=utf-8") -;; (exporter:export-xtm-to-string :revision (parse-integer revision) -;; :xtm-format '1.0)) - - -;; (defun fragments (&optional unique-id) -;; "Export a fragment by its unique id" -;; (assert unique-id) -;; (setf (content-type) "application/xtm+xml; charset=utf-8") -;; (let -;; ((fragment -;; (d:get-fragment (parse-integer unique-id)))) -;; (if fragment -;; (exporter:export-xtm-fragment fragment :xtm-format '1.0) -;; (format nil "")))) - - -;; (push -;; (create-regex-dispatcher "/feeds/?$" #'feeds) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/feeds/testtm/?$" #'tm-feed) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/snapshots/$" #'snapshot-feed) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/snapshots/([0-9]+)$" #'snapshots) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/fragments/?$" #'fragments-feed) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/fragments/([0-9]+)$" #'fragments) -;; hunchentoot:*dispatch-table*) - - (defvar *server-acceptor* nil) + (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* (error "Ther server is already running")) (setf hunchentoot:*show-lisp-errors-p* t) ;for now - ;(setf hunchentoot:*show-lisp-backtraces-p* t) ;hunchentoot 0.15.7 (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (setf atom:*base-url* (format nil "http://~a:~a" host-name port)) 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 Jul 8 07:02:04 2009 @@ -117,7 +117,9 @@ "Returns all topic-psi that are valid types -> so they have to be valid to the topictype-constraint (if it exists) and the can't be abstract." (declare (ignorable param)) - (handler-case (let ((topic-types (json-tmcl::return-all-tmcl-types))) + (handler-case (let ((topic-types + (with-reader-lock + (json-tmcl::return-all-tmcl-types)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -133,7 +135,9 @@ The validity is only oriented on the typing of topics, e.g. type-instance or supertype-subtype." (declare (ignorable param)) - (handler-case (let ((topic-instances (json-tmcl::return-all-tmcl-instances))) + (handler-case (let ((topic-instances + (with-reader-lock + (json-tmcl::return-all-tmcl-instances)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -152,7 +156,8 @@ (let ((topic (d:get-item-by-psi psi))) (if topic (let ((topic-json - (handler-case (json-exporter::to-json-topicStub-string topic) + (handler-case (with-reader-lock + (json-exporter::to-json-topicStub-string topic)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -176,7 +181,8 @@ (handler-case (let ((psis (json:decode-json-from-string json-data))) (let ((tmcl - (json-tmcl:get-constraints-of-fragment psis :treat-as treat-as))) + (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 @@ -200,7 +206,8 @@ (if (eq http-method :GET) (progn (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (handler-case (get-all-topic-psis) + (handler-case (with-reader-lock + (get-all-topic-psis)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -216,9 +223,11 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (create-latest-fragment-of-topic identifier))) + (with-writer-lock + (create-latest-fragment-of-topic identifier)))) (if fragment - (handler-case (to-json-string fragment) + (handler-case (with-reader-lock + (to-json-string fragment)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) @@ -239,7 +248,8 @@ (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 (json-importer:json-to-elem json-data) + (handler-case (with-writer-lock + (json-importer:json-to-elem json-data)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) @@ -257,31 +267,33 @@ (end-idx (handler-case (parse-integer (hunchentoot:get-parameter "end")) (condition () nil)))) - (handler-case (let ((topics (elephant:get-instances-by-class 'd:TopicC))) - (let ((end - (cond - ((not end-idx) - (length topics)) - ((> end-idx (length topics)) - (length topics)) - ((< end-idx 0) - 0) - (t - end-idx)))) - (let ((start + (handler-case (with-reader-lock + (let ((topics + (elephant:get-instances-by-class 'd:TopicC))) + (let ((end (cond - ((> start-idx (length topics)) - end) - ((< start-idx 0) + ((not end-idx) + (length topics)) + ((> end-idx (length topics)) + (length topics)) + ((< end-idx 0) 0) (t - start-idx)))) - (let ((topics-in-range - (if (<= start end) - (subseq topics start end) - (reverse (subseq topics end start))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (json-exporter:make-topic-summary topics-in-range))))) + end-idx)))) + (let ((start + (cond + ((> start-idx (length topics)) + end) + ((< start-idx 0) + 0) + (t + start-idx)))) + (let ((topics-in-range + (if (<= start end) + (subseq topics start end) + (reverse (subseq topics end start))))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (json-exporter:make-topic-summary topics-in-range)))))) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -292,7 +304,8 @@ "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) (handler-case (let ((json-string - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (with-reader-lock + (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 Modified: trunk/src/threading/reader-writer.lisp ============================================================================== --- trunk/src/threading/reader-writer.lisp (original) +++ trunk/src/threading/reader-writer.lisp Wed Jul 8 07:02:04 2009 @@ -7,66 +7,63 @@ ;;+----------------------------------------------------------------------------- -(defpackage :isidorus-reader-writer - (:use :cl :hunchentoot-mp) ;hunchentoot 0.15.7 +(defpackage :isidorus-threading + (:use :cl :bordeaux-threads) (:export :current-readers :with-reader-lock :with-writer-lock)) -(in-package :isidorus-reader-writer) - -(defvar *readerlist-mutex* (make-lock "isidorus current-readers lock")) ;hunchentoot 0.15.7 -(defvar *writer-mutex* (make-lock "isidorus writer lock")) ;hunchentoot 0.15.7 -;;(defvar *readerlist-mutex* (hunchentoot::make-lock "isidorus current-readers lock")) ;hunchentoot 1.0.0 -;;(defvar *writer-mutex* (hunchentoot::make-lock "isidorus writer lock")) ;hunchentoot 1.0.0 +(in-package :isidorus-threading) +(defvar *readerlist-lock* (make-lock "isidorus-threading: current readers lock")) +(defvar *writer-lock* (make-lock "isidorus-threading: writer lock")) (defvar *current-readers* nil) + (defun current-readers () - (let - ((result nil)) - ;;(with-lock (*readerlist-mutex*) ;hunchentoot 0.15.7 - (hunchentoot::with-lock-held (*readerlist-mutex*) ;hunchentoot 1.0.0 + "Returns a copy of the list which contains all current reader + threads, *current-readers*" + (let ((result nil)) + (with-lock-held (*readerlist-lock*) (setf result (copy-list *current-readers*))) result)) -(defun add-current-to-reader-list () - (with-lock (*writer-mutex*) ;hunchentoot 0.15.7 - (with-lock (*readerlist-mutex*) ;hunchentoot 0.15.7 - ;;(hunchentoot::with-lock-held (*writer-mutex*) ;hunchentoot 1.0.0 - ;;(hunchentoot::with-lock-held (*readerlist-mutex*) ;hunchentoot 1.0.0 - (push *current-process* *current-readers*)))) - -(defun remove-current-from-reader-list () - (with-lock (*readerlist-mutex*) ;hunchentoot 0.15.7 - ;;(hunchentoot::with-lock-held (*readerlist-mutex*) ;hunchentoot 1.0.0 + +(defun add-thread-to-reader-list () + "Adds the current thread to the reader list" + (with-lock-held (*writer-lock*) + (with-lock-held (*readerlist-lock*) + (push (current-thread) *current-readers*)))) + + +(defun remove-thread-from-reader-list () + "Removes the current threads from the reader list" + (with-lock-held (*readerlist-lock*) (setf *current-readers* - (delete *current-process* *current-readers*)))) + (delete (current-thread) *current-readers*)))) + (defmacro with-reader-lock (&body body) + "Executes the passed 'body' with the reader lock" `(progn - (add-current-to-reader-list) - (handler-case - (progn , at body) - (condition (c) - (progn - (remove-current-from-reader-list) - (error c)))) - (remove-current-from-reader-list))) - + (add-thread-to-reader-list) + (let ((result nil)) + (handler-case + (setf result , at body) + (condition (c) + (progn + (remove-thread-from-reader-list) + (error c)))) + (remove-thread-from-reader-list) + result))) + (defmacro with-writer-lock (&body body) - `(with-lock (*writer-mutex*) ;hunchentoot 0.15.7 - ;;`(hunchentoot::with-lock-held (*writer-mutex*) ;hunchetoot 1.0.0 + "Executes the passed body when the reader list is empty otherwise + the do macor loops in 500 ms time interval for a next chance." + `(with-lock-held (*writer-lock*) (do ((remaining-readers (current-readers) (current-readers))) - ((nullp remaining-raeders) nil) - ;; TODO: replace hunchentoot's internal function by - ;; something we are officially allowed to use. - ;; make sure the current thread sleeps for, say, 500ms. - (hunchentoot::process-allow-scheduling())) - , at body)) - - - - \ No newline at end of file + ((null remaining-readers)) + (sleep 0.5)) + , at body)) \ No newline at end of file Added: trunk/src/unit_tests/threading_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/threading_test.lisp Wed Jul 8 07:02:04 2009 @@ -0,0 +1,132 @@ +;;+----------------------------------------------------------------------------- +;;+ 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 :threading-test + (:use :cl + :it.bese.FiveAM + :isidorus-threading + :bordeaux-threads) + (:export :run-threading-tests + :test-helpers + :test-with-reader-lock + :test-with-writer-lock + :threading-test)) + + +(in-package :threading-test) + + +(def-suite threading-test + :description "tests various key functions of the threading module") + +(in-suite threading-test) + +(test test-helpers + "Tests the helper functions current-readers, add-thread-to-reader-list + and remove-thread-from-reader-list" + (is-true isidorus-threading::*readerlist-lock*) + (is-true isidorus-threading::*writer-lock*) + (is-false isidorus-threading::*current-readers*) + (is-false (progn + (isidorus-threading::remove-thread-from-reader-list) + (current-readers))) + (is (= 1 (length (progn + (isidorus-threading::add-thread-to-reader-list) + (current-readers))))) + (is (eql (first (current-readers)) (current-thread))) + (is (= 1 (length isidorus-threading::*current-readers*))) + (is-true (let ((copy-of-readers + (current-readers))) + (setf copy-of-readers nil) + isidorus-threading::*current-readers*)) + (setf isidorus-threading::*current-readers* nil) + (is-false (current-readers)) + (is (= 2 (length (progn + (isidorus-threading::add-thread-to-reader-list) + (isidorus-threading::add-thread-to-reader-list) + (isidorus-threading::current-readers))))) + (is (= 1 (progn + (isidorus-threading::remove-thread-from-reader-list) + (push t isidorus-threading::*current-readers*) + (length (current-readers))))) + (setf isidorus-threading::*current-readers* nil)) + + +(test test-with-reader-lock + "Tests the macro with-reader-lock" + (is-true isidorus-threading::*readerlist-lock*) + (is-true isidorus-threading::*writer-lock*) + (is-false isidorus-threading::*current-readers*) + (let ((thread-1 + (make-thread #'(lambda() + (with-reader-lock (sleep 3))))) + (thread-2 + (make-thread #'(lambda() + (with-reader-lock (sleep 3))))) + (thread-3 + (make-thread #'(lambda() + (with-reader-lock (sleep 3)))))) + (is (= 3 (length (current-readers)))) + (is-true (find thread-1 (current-readers))) + (is-true (find thread-2 (current-readers))) + (is-true (find thread-3 (current-readers))) + (sleep 4) + (is-false (current-readers))) + (setf isidorus-threading::*current-readers* nil) + (make-thread #'(lambda() + (with-lock-held (isidorus-threading::*readerlist-lock*) + (sleep 3)))) + (let ((start-time + (get-universal-time))) + (isidorus-threading::add-thread-to-reader-list) + (is (<= (+ 2 start-time) (get-universal-time)))) + (setf isidorus-threading::*current-readers* nil) + (let ((start-time + (get-universal-time))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (is (> (+ start-time 3) (get-universal-time))) + (is (= 2 (length (current-readers)))) + (sleep 4)) + (is-false (current-readers))) + + +(test test-with-writer-lock + "Tests the macro with-writer-lock" + (is-true isidorus-threading::*readerlist-lock*) + (is-true isidorus-threading::*writer-lock*) + (is-false isidorus-threading::*current-readers*) + (let ((start-time + (get-universal-time))) + (with-writer-lock nil) + (is (>= (+ 1 start-time) (get-universal-time)))) + (make-thread #'(lambda() + (with-reader-lock #'(lambda() + (sleep 3))))) + (let ((start-time + (get-universal-time))) + (make-thread #'(lambda() (with-writer-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (is-false (current-readers)) + (with-writer-lock nil) + (is (<= (+ 3 start-time) (get-universal-time)))) + (let ((start-time + (get-universal-time))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (with-writer-lock nil) + (is (<= (+ start-time 3) (get-universal-time))))) + + +(defun run-threading-tests () + "Runs all defined tests in this package" + (it.bese.fiveam:run! 'test-helpers) + (it.bese.fiveam:run! 'test-with-reader-lock) + (it.bese.fiveam:run! 'test-with-writer-lock)) \ No newline at end of file Modified: trunk/src/xml/exporter.lisp ============================================================================== --- trunk/src/xml/exporter.lisp (original) +++ trunk/src/xml/exporter.lisp Wed Jul 8 07:02:04 2009 @@ -68,44 +68,47 @@ tm-id (revision (get-revision)) (xtm-format '2.0)) - (let - ((tm - (when tm-id - (get-item-by-item-identifier tm-id :revision revision)))) - (setf *export-tm* tm) - (with-revision revision - (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-reader-lock + (let + ((tm + (when tm-id + (get-item-by-item-identifier tm-id :revision revision)))) + (setf *export-tm* tm) + (with-revision revision + (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 (export-to-elem tm #'to-elem)) - (with-xtm1.0 - (export-to-elem tm #'to-elem-xtm1.0)))))))) + (with-xtm1.0 + (export-to-elem tm #'to-elem-xtm1.0))))))))) (defun export-xtm-to-string (&key tm-id (revision (get-revision)) (xtm-format '2.0)) - (let - ((tm - (when tm-id - (get-item-by-item-identifier tm-id :revision revision)))) - (with-revision revision - (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)) - (with-xtm1.0 - (export-to-elem tm #'to-elem-xtm1.0))))))) + (with-reader-lock + (let + ((tm + (when tm-id + (get-item-by-item-identifier tm-id :revision revision)))) + (with-revision revision + (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)) + (with-xtm1.0 + (export-to-elem tm #'to-elem-xtm1.0)))))))) (defun export-xtm-fragment (fragment &key (xtm-format '2.0)) (declare (FragmentC fragment)) - (with-revision (revision fragment) - (cxml:with-xml-output (cxml:make-string-sink :canonical nil) - (if (eq xtm-format '2.0) - (with-xtm2.0 + (with-reader-lock + (with-revision (revision fragment) + (cxml:with-xml-output (cxml:make-string-sink :canonical nil) + (if (eq xtm-format '2.0) + (with-xtm2.0 (to-elem fragment)) - (with-xtm1.0 - (to-elem-xtm1.0 fragment)))))) + (with-xtm1.0 + (to-elem-xtm1.0 fragment))))))) \ No newline at end of file Modified: trunk/src/xml/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/exporter_xtm1.0.lisp Wed Jul 8 07:02:04 2009 @@ -8,7 +8,7 @@ (defpackage :exporter - (:use :cl :cxml :elephant :datamodel) + (:use :cl :cxml :elephant :datamodel :isidorus-threading) (:import-from :constants *XTM2.0-NS* *XTM1.0-NS* Modified: trunk/src/xml/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/exporter_xtm2.0.lisp Wed Jul 8 07:02:04 2009 @@ -25,18 +25,6 @@ (cxml:attribute "href" (uri psi)))) -;; (defmethod to-elem ((scope ScopeC)) -;; (cxml:with-element "t:scope" -;; (append -;; (map 'list #'ref-to-elem (themes scope))))) - - -;; (defun scopes-to-elem (scopes) -;; (when scopes -;; (cxml:with-element "t:scope" -;; (map 'list #'ref-to-elem scopes)))) - - (defmethod to-elem ((name NameC)) "name = element name { reifiable, type?, scope?, value, variant* }" Modified: trunk/src/xml/importer.lisp ============================================================================== --- trunk/src/xml/importer.lisp (original) +++ trunk/src/xml/importer.lisp Wed Jul 8 07:02:04 2009 @@ -16,7 +16,7 @@ ;; (defpackage :xml-importer - (:use :cl :cxml :elephant :datamodel) + (:use :cl :cxml :elephant :datamodel :isidorus-threading) (:import-from :constants *type-instance-psi* *type-psi* @@ -124,18 +124,19 @@ "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 core TM" - (with-tm (revision "core.xtm" "http://www.topicmaps.org/xtm/1.0/core.xtm") - (let - ((core-dom - (cxml:parse-file *core_psis.xtm* (cxml-dom:make-dom-builder)))) - (loop for top-elem across - (xpath-child-elems-by-qname (dom:document-element core-dom) - *xtm2.0-ns* "topic") - do - (let - ((top - (from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm"))) - (add-to-topicmap tm top)))))) + (with-writer-lock + (with-tm (revision "core.xtm" "http://www.topicmaps.org/xtm/1.0/core.xtm") + (let + ((core-dom + (cxml:parse-file *core_psis.xtm* (cxml-dom:make-dom-builder)))) + (loop for top-elem across + (xpath-child-elems-by-qname (dom:document-element core-dom) + *xtm2.0-ns* "topic") + do + (let + ((top + (from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm"))) + (add-to-topicmap tm top))))))) ;TODO: replace the two importers with this macro (defmacro importer-mac Modified: trunk/src/xml/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/importer_xtm1.0.lisp (original) +++ trunk/src/xml/importer_xtm1.0.lisp Wed Jul 8 07:02:04 2009 @@ -443,22 +443,23 @@ (declare (dom:element xtm-dom)) (declare (integer revision)) (assert elephant:*store-controller*) - (with-tm (revision xtm-id tm-id) - (let - ((topic-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "topic")) - (assoc-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "association"))) - (loop for topic across topic-vector - do (from-topic-elem-to-stub-xtm1.0 topic revision - :xtm-id xtm-id)) - (loop for top-elem across topic-vector - do - (format t "t") - (merge-topic-elem-xtm1.0 top-elem revision - :tm tm - :xtm-id xtm-id)) - (loop for assoc-elem across assoc-vector - do - (format t "a") - (from-association-elem-xtm1.0 assoc-elem revision - :tm tm - :xtm-id xtm-id))))) + (with-writer-lock + (with-tm (revision xtm-id tm-id) + (let + ((topic-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "topic")) + (assoc-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "association"))) + (loop for topic across topic-vector + do (from-topic-elem-to-stub-xtm1.0 topic revision + :xtm-id xtm-id)) + (loop for top-elem across topic-vector + do + (format t "t") + (merge-topic-elem-xtm1.0 top-elem revision + :tm tm + :xtm-id xtm-id)) + (loop for assoc-elem across assoc-vector + do + (format t "a") + (from-association-elem-xtm1.0 assoc-elem revision + :tm tm + :xtm-id xtm-id)))))) Modified: trunk/src/xml/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/importer_xtm2.0.lisp (original) +++ trunk/src/xml/importer_xtm2.0.lisp Wed Jul 8 07:02:04 2009 @@ -409,20 +409,21 @@ (declare (dom:element xtm-dom)) (declare (integer revision)) ;all topics that are imported in one go share the same revision (assert elephant:*store-controller*) - (with-tm (revision xtm-id tm-id) - (let - ((topic-vector (get-topic-elems xtm-dom)) - (assoc-vector (get-association-elems xtm-dom))) - (loop for top-elem across topic-vector do - (from-topic-elem-to-stub top-elem revision - :xtm-id xtm-id)) - (loop for top-elem across topic-vector do - (format t "t") - (merge-topic-elem top-elem revision - :tm tm - :xtm-id xtm-id)) - (loop for assoc-elem across assoc-vector do - (format t "a") - (from-association-elem assoc-elem revision - :tm tm - :xtm-id xtm-id))))) + (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))) + (loop for top-elem across topic-vector do + (from-topic-elem-to-stub top-elem revision + :xtm-id xtm-id)) + (loop for top-elem across topic-vector do + (format t "t") + (merge-topic-elem top-elem revision + :tm tm + :xtm-id xtm-id)) + (loop for assoc-elem across assoc-vector do + (format t "a") + (from-association-elem assoc-elem revision + :tm tm + :xtm-id xtm-id)))))) Modified: trunk/src/xml/setup.lisp ============================================================================== --- trunk/src/xml/setup.lisp (original) +++ trunk/src/xml/setup.lisp Wed Jul 8 07:02:04 2009 @@ -19,25 +19,26 @@ (xtm-format '2.0) (xtm-id (get-uuid))) "Imports an XTM file into an existing repository using the correct -importer for the XTM version. Does *not* close the store afterwards" + 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))))) + (truename xtm-path) (cxml-dom:make-dom-builder))))) (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) - ;create the topic stubs so that we can refer to them later on + ;create the topic stubs so that we can refer to them later on (setf d:*current-xtm* xtm-id) (if (eq xtm-format '2.0) - (importer xtm-dom :tm-id tm-id :xtm-id xtm-id) - (importer-xtm1.0 xtm-dom :tm-id tm-id :xtm-id xtm-id)) - (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" - (length (elephant:get-instances-by-class 'TopicC)) - (length (elephant:get-instances-by-class 'AssociationC))))) - ;(format t "#Topics in the store: ~a~%" (length (elephant:get-instances-by-class 'TopicC))))) + (importer xtm-dom :tm-id tm-id :xtm-id xtm-id) + (importer-xtm1.0 xtm-dom :tm-id tm-id :xtm-id xtm-id)) + (with-reader-lock + (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" + (length (elephant:get-instances-by-class 'TopicC)) + (length (elephant:get-instances-by-class 'AssociationC)))))) + (defun setup-repository (xtm-path repository-path &key tm-id @@ -46,11 +47,10 @@ "Initializes a repository and imports a XTM file into it" (declare ((or pathname string) xtm-path)) (declare ((or pathname string) repository-path)) - (unless elephant:*store-controller* (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 + (elephant:close-store))) \ No newline at end of file From lgiessmann at common-lisp.net Thu Jul 9 14:21:38 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 09 Jul 2009 10:21:38 -0400 Subject: [isidorus-cvs] r91 - in trunk/src: rest_interface unit_tests Message-ID: Author: lgiessmann Date: Thu Jul 9 10:21:37 2009 New Revision: 91 Log: RESTful interface: changed some procedures that creates some dispatchers for hunchentoot's dispatcherlist. There is used the function create-static-file-dispathcer-and-handler instead of using create-regex-dispather. Too much calls of create-regex-dispatcher leads to a memory-problem of the heap (on london) Modified: trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/poems.xtm 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 Jul 9 10:21:37 2009 @@ -19,7 +19,7 @@ (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-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 @@ -52,27 +52,25 @@ (push hunchentoot:+http-internal-server-error+ hunchentoot:*approved-return-codes*) ;; === html and css files ==================================================== (push - (create-regex-dispatcher ajax-user-interface-url - #'(lambda() - (hunchentoot:handle-static-file ajax-user-interface-file-path "text/html"))) + (create-static-file-dispatcher-and-handler ajax-user-interface-url ajax-user-interface-file-path "text/html") hunchentoot:*dispatch-table*) (dolist (script-path-and-url (make-file-path-and-url ajax-user-interface-css-directory-path ajax-user-interface-css-prefix)) (let ((script-path (getf script-path-and-url :path)) (script-url (getf script-path-and-url :url))) - (push (create-regex-dispatcher script-url - #'(lambda() - (hunchentoot:handle-static-file script-path))); "text/javascript"))) - hunchentoot:*dispatch-table*))) + (push + (create-static-file-dispatcher-and-handler script-url script-path) + hunchentoot:*dispatch-table*))) + ;; === ajax frameworks and javascript files ================================== (dolist (script-path-and-url (make-file-path-and-url ajax-javascripts-directory-path ajax-javascripts-url-prefix)) (let ((script-path (getf script-path-and-url :path)) (script-url (getf script-path-and-url :url))) - (push (create-regex-dispatcher script-url - #'(lambda() - (hunchentoot:handle-static-file script-path))); "text/javascript"))) - hunchentoot:*dispatch-table*))) + (push + (create-static-file-dispatcher-and-handler script-url script-path) + hunchentoot:*dispatch-table*))) + ;; === rest interface ======================================================== (push Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Thu Jul 9 10:21:37 2009 @@ -2765,7 +2765,6 @@ - @@ -2807,7 +2806,6 @@ - From lgiessmann at common-lisp.net Wed Jul 15 13:05:09 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 15 Jul 2009 09:05:09 -0400 Subject: [isidorus-cvs] r92 - in trunk/src: . ajax/javascripts xml xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Wed Jul 15 09:05:08 2009 New Revision: 92 Log: rdf-module: restructured the xml-module -> the entire xml-module is separated into an xtm-module which contains all files that have already existed. currently there exists an rdf-module which will contain all necessary files for importing/exporting rdf-data Added: trunk/src/xml/rdf/ trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/xtm/ trunk/src/xml/xtm/core_psis.xtm (props changed) - copied unchanged from r26, /trunk/src/xml/core_psis.xtm trunk/src/xml/xtm/exporter.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/exporter.lisp trunk/src/xml/xtm/exporter_xtm1.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/xtm/exporter_xtm2.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/exporter_xtm2.0.lisp trunk/src/xml/xtm/importer.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/importer.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/importer_xtm1.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/importer_xtm2.0.lisp trunk/src/xml/xtm/setup.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/setup.lisp trunk/src/xml/xtm/tools.lisp (props changed) - copied unchanged from r26, /trunk/src/xml/tools.lisp Removed: trunk/src/xml/core_psis.xtm trunk/src/xml/exporter.lisp trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/exporter_xtm2.0.lisp trunk/src/xml/importer.lisp trunk/src/xml/importer_xtm1.0.lisp trunk/src/xml/importer_xtm2.0.lisp trunk/src/xml/setup.lisp trunk/src/xml/tools.lisp Modified: trunk/src/ajax/javascripts/datamodel.js trunk/src/isidorus.asd trunk/src/xml-constants.lisp Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Wed Jul 15 09:05:08 2009 @@ -1506,13 +1506,6 @@ this.__scope__.disable(); this.__value__.__frames__[0].disable(); this.__variants__.disable(); -/* - disableItemIdentity(this); - disableType(this); - disableScope(this); - disableValue(this); - disableVariants(this); - this.getFrame().setStyle(DISABLED_BACKGROUND_COLOR);*/ this.getFrame().writeAttribute({"class" : CLASSES.disabled()}); this.getFrame().writeAttribute({"title" : this.__cssTitle__}); this.hideAddButton(); @@ -1524,12 +1517,6 @@ this.__scope__.enable(); this.__value__.__frames__[0].enable(); this.__variants__.enable(); -/* - enableItemIdentity(this); - enableType(this); - enableScope(this); - enableValue(this); - enableVariants(this);*/ this.getFrame().writeAttribute({"class" : CLASSES.nameFrame()}); this.getFrame().removeAttribute("title"); checkRemoveAddButtons(this.__owner__, 1, this.__max__, this); Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Jul 15 09:05:08 2009 @@ -19,9 +19,9 @@ :licence "LGPL" :components ( (:file "constants") - (:static-file "xml/core_psis.xtm") + (:static-file "xml/xtm/core_psis.xtm") (:file "xml-constants" - :depends-on ("xml/core_psis.xtm" + :depends-on ("xml/xtm/core_psis.xtm" "constants")) (:module "model" :components ((:file "exceptions") @@ -33,22 +33,26 @@ :depends-on ("exceptions"))) :depends-on ("constants")) (:module "xml" - :components ((:file "tools") - (:file "importer" - :depends-on ("tools")) - (:file "importer_xtm2.0" - :depends-on ("importer")) - (:file "importer_xtm1.0" - :depends-on ("importer")) - (:file "setup" - :depends-on ("importer_xtm2.0" - "importer_xtm1.0")) - (:file "exporter_xtm1.0") - (:file "exporter_xtm2.0" - :depends-on ("exporter_xtm1.0")) - (:file "exporter" - :depends-on ("exporter_xtm1.0" - "exporter_xtm2.0"))) + :components ((:module "xtm" + :components ((:file "tools") + (:file "importer" + :depends-on ("tools")) + (:file "importer_xtm2.0" + :depends-on ("importer")) + (:file "importer_xtm1.0" + :depends-on ("importer")) + (:file "setup" + :depends-on ("importer_xtm2.0" + "importer_xtm1.0")) + (:file "exporter_xtm1.0") + (:file "exporter_xtm2.0" + :depends-on ("exporter_xtm1.0")) + (:file "exporter" + :depends-on ("exporter_xtm1.0" + "exporter_xtm2.0")))) + (:module "rdf" + :components ((:file "importer") + (:file "exporter")))) :depends-on ("constants" "xml-constants" "model" Modified: trunk/src/xml-constants.lisp ============================================================================== --- trunk/src/xml-constants.lisp (original) +++ trunk/src/xml-constants.lisp Wed Jul 15 09:05:08 2009 @@ -22,5 +22,5 @@ (defparameter *core_psis.xtm* (asdf:component-pathname - (asdf:find-component *isidorus-system* "xml/core_psis.xtm"))) + (asdf:find-component *isidorus-system* "xml/xtm/core_psis.xtm"))) Added: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/exporter.lisp Wed Jul 15 09:05:08 2009 @@ -0,0 +1,7 @@ +;;+----------------------------------------------------------------------------- +;;+ 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. +;;+----------------------------------------------------------------------------- \ No newline at end of file Added: trunk/src/xml/rdf/importer.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/importer.lisp Wed Jul 15 09:05:08 2009 @@ -0,0 +1,7 @@ +;;+----------------------------------------------------------------------------- +;;+ 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. +;;+----------------------------------------------------------------------------- \ No newline at end of file From lgiessmann at common-lisp.net Sun Jul 19 17:07:24 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 19 Jul 2009 13:07:24 -0400 Subject: [isidorus-cvs] r93 - trunk/docs Message-ID: Author: lgiessmann Date: Sun Jul 19 13:07:23 2009 New Revision: 93 Log: added a ebnf schema for the used json model Added: trunk/docs/json.ebnf Removed: trunk/docs/JSON_model.pdf Added: trunk/docs/json.ebnf ============================================================================== --- (empty file) +++ trunk/docs/json.ebnf Sun Jul 19 13:07:23 2009 @@ -0,0 +1,130 @@ +//+----------------------------------------------------------------------------- +//+ Overview: +//+ *Part 1: Basic elements +//+ *Part 2: XTM - data model +//+ *Part 3: Object summaries +//+ *Part 4: TMCL - data model +//+ *Part 5: Server-side RESTful interface +//+----------------------------------------------------------------------------- + +//+----------------------------------------------------------------------------- +//+ Part 1: Basic elements +//+----------------------------------------------------------------------------- + +Char = "a" | "b" | ... | "A" | "B" | "0" | "1" | ... +String = "\"" char* "\"" +Null = "\"null\"" +List = "[" string ("," string)* "]" +DblList = ("[" List ("," List)* "]") +TrpList = ("[" DblList ("," DblList)* "]") +Bool = "\"true\"" | "\"false\"" +Cipher = "1" | "2" | ... +Number = "\"0\"" | "\"" (Cipher (Cipher | "0")*) "\"" +ENumber = Number | "\"MAX_INT\"" + + +//+----------------------------------------------------------------------------- +//+ Part 2: XTM - data model +//+----------------------------------------------------------------------------- +Datatype = "\"datatype\":" String +Value = "\"value\":" String +Data = "\"resourceData\":{" Datatype "," Value "}" +RData = "\"resourceRef\":" ((string ",\"resourceData\":null") | (Null "," Data)) + +ItemIdentity = "\"itemIdentities\":" (List | Null) +SubjectLocator = "\"subjectLocators\":" (List | Null) +SubjectIdentifier = "\"subjectItentifers\":" (List | Null) +Scope = "\"scopes\":" (DblList | Null) +InstanceOf = "\"instanceOfs\":" (DblList | Null) +Type = "\"type\":" List +ID = "\id\":" string +TopicRef = "\"topicRef\":" List + +Variant = "{" ItemIdentity "," Scope "," RData "}" +Variants = "\"variants\":" (("[" Variant+ "]") | Null) + +Name = "{" ItemIdentity "," Type "," Scope "," Value "," Variants "}" +Names = "\"names\":" ("[" Name+ "]") | Null + +Occurrence = "{" ItemIdentity "," Type "," Scope "," RData "}" +Occurrences = "\"occurrences\":" (("[" Occurrence+ "]") | Null) + +Topic = "\"topic\":{" ID "," ItemIdentity "," SubjectLocator "," + SubjectIdentifier "," InstanceOf "," Names "," Occurences "}" + +Role = "{" ItemIdentity "," Type "," TopicRef "}" +Roles = "\"roles\":" (("[" Role+ "]") | Null) + +Association = "{" ItemIdentity "," Type "," Scope "," Roles "}" +Associations "\"associations\":" (("[" Association "]") | Null) + +TopicStub = "{" ID "," ItemIdentity "," SubjectLocator "," SubjectIdentifier "}" +TopicStubs = "\"topicStubs\":" (("[" TopicStub+ "]") | Null) + +TmIDs = "\"tmIds\":" List + +Fragment = "{" Topic "," TopicStubs "," Associations "," TmIDs "}" + + +//+----------------------------------------------------------------------------- +//+ Part 3: Object summaries +//+----------------------------------------------------------------------------- +PsiSummary = DblList | Null + +NameSummary = "\"names\":" (List | Null) +OccurrenceSummary = "\"occurrences\":" (List | Null) + +TopicSummary = "{" ID "," ItemIdentity "," SubjectLocator "," + SubjectIdentifier "," InstanceOf "," NameSummary "," + OccurrenceSummary "}" +TopicSummaries = ("[" TopicSummary+ "]") | Null + +TopicList = "\"topic\":" List +IsType = "\isType\":" Bool +IsInstance = "\"isInstance\":" Bool +Instances = "\"instances\":" (("[" TreeNode "]") | Null) + +TreeNode = "{" TopicList "," isType "," isInstance "," Instances "}" + + +//+----------------------------------------------------------------------------- +//+ Part 4: TMCL - data model +//+----------------------------------------------------------------------------- +CardMin = "\"cardMin\":" Number +CardMax = "\"cardMax\":" ENumber +RegExp = "\"regexp\":" String + +ExclusiveInstance = "{\"owner\":" List ",\"exclisives\":" (DblList | Null) "}" +SimpleConstraint = "{" RegExp "," CardMin "," CardMax "}" +Constraints = "\"constraints\":[" SimpleConstraint+ "]" + + +ScopeType = "\"scopeTypes\":" TrpList +ScopeConstraint = "{" ScopeType "," CardMin "," CardMax "}" +ScopeConstraints = "\"scopeConstraints\":" (("[" scopeConstraint "]") | Null) + +NameTypeScope = "{\"nameType\":" List "," scopeConstraints "}" +NameTypeScopes = "\"nametypescopes\":[" NameTypeScope+ "]" +TopicNameConstraint = "{" NameTypeScopes "," Constraints "}" + +UniqueConstraints = "\"uniqeConstraints\":[" SimpleConstraint+ "]" +DatatypeConstraint = "\"datatypeConstraint\":" String +OccurrenceTypeScope = "{\"occurrenceType\":" List "," scopeConstraints "," + DatatypeConstraint "}" +OccurrenceTypeScopes = "\"occurrenceTypes\":[" OccurrenceTypeScope+ "]" +TopicOccurrenceConstraint = "{" OccurrenceTyoeScopes "," Constraints "," + UniqueConstraints "}" + +//+----------------------------------------------------------------------------- +//+ Part 5: Server-side RESTful interface +//+----------------------------------------------------------------------------- +"/json/get/(.+)$" returns a Fragment after a HTTP-GET +"/json/commit/?$" processes a Fragment as HTTP-POST or HTTP-PUT +"/json/psis/?$" returns a PsiSummary after a HTTP-GET +"/json/summary/?$" returns a TopicSummaries after A HTTP-GET +"/json/tmcl/types/?$" +"/json/tmcl/instances/?$" +"/json/topicstubs/(.+)$" +"/json/tmcl/type/?$" +"/json/tmcl/instance/?$" +"/json/tmcl/overview/?$" \ No newline at end of file From lgiessmann at common-lisp.net Sun Jul 19 18:42:47 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 19 Jul 2009 14:42:47 -0400 Subject: [isidorus-cvs] r94 - trunk/docs Message-ID: Author: lgiessmann Date: Sun Jul 19 14:42:47 2009 New Revision: 94 Log: finalized the JSON ebnf schema Modified: trunk/docs/json.ebnf Modified: trunk/docs/json.ebnf ============================================================================== --- trunk/docs/json.ebnf (original) +++ trunk/docs/json.ebnf Sun Jul 19 14:42:47 2009 @@ -11,7 +11,7 @@ //+ Part 1: Basic elements //+----------------------------------------------------------------------------- -Char = "a" | "b" | ... | "A" | "B" | "0" | "1" | ... +Char = "a" | "b" | ... | "A" | "B" | ... | "0" | "1" | ... | "-" | "_" | ... String = "\"" char* "\"" Null = "\"null\"" List = "[" string ("," string)* "]" @@ -25,6 +25,10 @@ //+----------------------------------------------------------------------------- //+ Part 2: XTM - data model +//+ A fragment contains a valid but incomplete topic map with one main topic +//+ all referenced associations and all referenced topic stubs. +//+ The schema is close to XTM 2.0 with the difference that referencing topics +//+ is done via their PSIs, so a reference is always a list of PSIs. //+----------------------------------------------------------------------------- Datatype = "\"datatype\":" String Value = "\"value\":" String @@ -68,6 +72,10 @@ //+----------------------------------------------------------------------------- //+ Part 3: Object summaries +//+ These Summaries are necessary to offer information of existing topics in the +//+ store. A PsiSummary contains a list of PSI lists, so the client is able to +//+ find out all existing topics. The TreeView contains a hierarchical +//+ map of the stored Topics. //+----------------------------------------------------------------------------- PsiSummary = DblList | Null @@ -85,7 +93,7 @@ Instances = "\"instances\":" (("[" TreeNode "]") | Null) TreeNode = "{" TopicList "," isType "," isInstance "," Instances "}" - +TreeView = ("[" TreeNode+ "]") | Null //+----------------------------------------------------------------------------- //+ Part 4: TMCL - data model @@ -94,27 +102,77 @@ CardMax = "\"cardMax\":" ENumber RegExp = "\"regexp\":" String -ExclusiveInstance = "{\"owner\":" List ",\"exclisives\":" (DblList | Null) "}" SimpleConstraint = "{" RegExp "," CardMin "," CardMax "}" Constraints = "\"constraints\":[" SimpleConstraint+ "]" - +// Contains the owner instances and all topic types that are defined +// es exclusives for the owner type +ExclusiveInstances = "\"exclusiveInstances\":{\"owner\":" List + ",\"exclisives\":" (DblList | Null) "}" + +// Contains a list of constraints that offer information about +// the regular expressions and cardinalities for subjectIdentifiers +// or subjectLocators +SubjectIdentifierConstraints = "\"subjectIdentifierConstraints\":" (Constraints | Null) +SubjectLocatorConstraints = "\"subjectLocatorConstraints\":" (Constraints | Null) + +// Offers scope information. The ScopeType contains a representation of all +// available scopes and their subtys. Further constructs describe the +// cardinalities ScopeType = "\"scopeTypes\":" TrpList ScopeConstraint = "{" ScopeType "," CardMin "," CardMax "}" ScopeConstraints = "\"scopeConstraints\":" (("[" scopeConstraint "]") | Null) +// Describes a name constraint for a nametype and its subtypes. NameTypeScope = "{\"nameType\":" List "," scopeConstraints "}" NameTypeScopes = "\"nametypescopes\":[" NameTypeScope+ "]" TopicNameConstraint = "{" NameTypeScopes "," Constraints "}" +TopicNameConstraints "\"topicNameConstraints\":" (("[" TopicNameConstraint+ "]") | Null) +// Describes an occurrence constraint for an occurencetype and its subtypes. UniqueConstraints = "\"uniqeConstraints\":[" SimpleConstraint+ "]" DatatypeConstraint = "\"datatypeConstraint\":" String OccurrenceTypeScope = "{\"occurrenceType\":" List "," scopeConstraints "," DatatypeConstraint "}" OccurrenceTypeScopes = "\"occurrenceTypes\":[" OccurrenceTypeScope+ "]" -TopicOccurrenceConstraint = "{" OccurrenceTyoeScopes "," Constraints "," +TopicOccurrenceConstraint = "{" OccurrenceTypeScopes "," Constraints "," UniqueConstraints "}" +TopicOccurrenceConstraints = "\"topicOccurrenceConstraints\":" + (("[" TopicOccurrenceConstraints+ "]") | Null) + +// Contains all constraints that depends on a topic +TopicConstraint = "{" ExclusiveInstances "," SubjectIdentifierConstraints "," + SubjectLocatorConstraints "," TopicNameConstraints "," + TopicOccurrenceConstraints "," AbstractConstraint "}" + +// Describes an associationrole-constraint +RoleType = "\"roleType\":" DblList +ARC = "{" RoleType "," cardMin "," cardMax "}" +ARCs = "\"AssociationRoleConstraints\":" (("[" ARC+ "]") | Null) + +// Describes a roleplayer-constraint and also contains all possible +// players. +PlayerType = "\"playerType\":" DblList +Players = "\"players\":" DblList +RPC = "{" playerType "," Players "," RoleType "," cardMin "," cardMax "}" +RPCs = "\"rolePlayerConstraints\":" (("[" RPC+ "]") | Null) + +// Describes an otherrole-constraint and also contains all possible +// players and otherplayers. +OtherRoleType = "\"otherRoleType\":" DblList +OtherPlayerType = "\"otherPlayewrType\":" DblList +OtherPlayers = "\"otherPlayers\":" DblList +ORC = "{" PlayerType "," Players "," RoleType "," OtherPlayerType "," + OtherPlayers "," OtherRoleType "," cardMin "," cardMax "}" +ORCs "\"otehrRoleConstraints\":" (("[" ORC+ "]") | Null) + +// Describes all constraints of all associations depending to the topic +AssocType = "\"associationType\":" List +AConstraints = "{" AssocType "," ARCs "," RPCs "," ORCs "," ScopeConstraints "}" +AssociationsConstraints "\"associationsConstraints\":" (("[" AConstraints+ "]") | Null) +// Contains the entire TMCL information +FragmentConstraint ="{" TopicConstraints "," AssociationsConstraints "}" //+----------------------------------------------------------------------------- //+ Part 5: Server-side RESTful interface //+----------------------------------------------------------------------------- @@ -122,9 +180,9 @@ "/json/commit/?$" processes a Fragment as HTTP-POST or HTTP-PUT "/json/psis/?$" returns a PsiSummary after a HTTP-GET "/json/summary/?$" returns a TopicSummaries after A HTTP-GET -"/json/tmcl/types/?$" -"/json/tmcl/instances/?$" -"/json/topicstubs/(.+)$" -"/json/tmcl/type/?$" -"/json/tmcl/instance/?$" -"/json/tmcl/overview/?$" \ No newline at end of file +"/json/tmcl/types/?$" returns a PsiSummary after A HTTP-GET with all types +"/json/tmcl/instances/?$" returns a PsiSummary after a HTTP-GET with all instances +"/json/topicstubs/(.+)$" returns a topicStub after a HTTP-GET +"/json/tmcl/type/?$" returns a FragmentConstraint after a HTTP-POST/HTTP-PUT +"/json/tmcl/instance/?$" returns a FragmentConstraint after a HTTP-POST/HTTP-PUT +"/json/tmcl/overview/?$" returns a TreeView after a HTTP-GET \ No newline at end of file From lgiessmann at common-lisp.net Mon Jul 27 07:18:43 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 27 Jul 2009 03:18:43 -0400 Subject: [isidorus-cvs] r95 - in trunk/src: . unit_tests xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Mon Jul 27 03:18:41 2009 New Revision: 95 Log: created the initial rdf-document-structure Added: trunk/src/unit_tests/poems.rdf trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/xml/rdf/importer.lisp trunk/src/xml/xtm/setup.lisp trunk/src/xml/xtm/tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Mon Jul 27 03:18:41 2009 @@ -20,7 +20,12 @@ :*subtype-psi* :*xtm2.0-ns* :*xtm1.0-ns* - :*xtm1.0-xlink*)) + :*xtm1.0-xlink* + :*rdf-ns* + :*rdfs-ns* + :*xml-ns* + :*xmlns-ns* + :*xml-string*)) (in-package :constants) (defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/") @@ -46,3 +51,13 @@ (defparameter *subtype-psi* "http://psi.topicmaps.org/iso13250/model/subtype") (defparameter *isidorus-system* (asdf:find-system "isidorus")) + +(defparameter *rdf-ns* "http://www.w3.org/1999/02/22-rdf-syntax-ns#") + +(defparameter *rdfs-ns* "http://www.w3.org/2000/01/rdf-schema#") + +(defparameter *xml-ns* "http://www.w3.org/XML/1998/namespace") + +(defparameter *xmlns-ns* "http://www.w3.org/2000/xmlns/") + +(defparameter *xml-string* "http://www.w3.org/2001/XMLSchema#string") \ No newline at end of file Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Mon Jul 27 03:18:41 2009 @@ -51,8 +51,11 @@ :depends-on ("exporter_xtm1.0" "exporter_xtm2.0")))) (:module "rdf" - :components ((:file "importer") - (:file "exporter")))) + :components ((:file "rdf_tools") + (:file "importer" + :depends-on ("rdf_tools")) + (:file "exporter")) + :depends-on ("xtm"))) :depends-on ("constants" "xml-constants" "model" @@ -100,6 +103,8 @@ (:static-file "sample_objects.xtm") (:static-file "t100.xtm") (:static-file "atom_test.xtm") + (:static-file "poems.xtm") + (:static-file "poems.rdf") (:file "atom-conf") (:file "unittests-constants" :depends-on ("dangling_topicref.xtm" Added: trunk/src/unit_tests/poems.rdf ============================================================================== --- (empty file) +++ trunk/src/unit_tests/poems.rdf Mon Jul 27 03:18:41 2009 @@ -0,0 +1,8642 @@ + + + + + + Johann Wolfgang + von Goethe + + + + + 28.08.1749 + + + + + + + + Frankfurt am Main + 659000 + + + + + + Deutschland + 82099232 + + + + + + + + 3431473 + + + + + + + + + + + + + + 22.03.1832 + + + 64720 + + + + + + + + + + + + Der Zauberlehrling + + 01.01.1797 + 31.12.1797 + + + + + + + + + + + + + + + + 01.01.1782 + 01.01.1782 + + + + + + + + + + + + 1772 + 1774 + + + + + + + + + + + + + + + + + + + + + 10.11.1759 + + + + + + + + + 09.05.1805 + + + + + + + + + + + + 01.01.1786 + 31.12.1786 + + + + + + + + + + + 01.01.1781 + 31.12.1781 + + + + + + + + + + + + + + 15601 + + + + + + + + + + + 10.03.1788 + + + + + + + + 365 + + + 38115909 + + + + + + + + + 1709781 + + + + + + + + + + + + + + 26.11.1857 + + + 46000 + + + + + + + + + + + + + 01.01.1837 + 31.12.1837 + + + + + + + + + Die zwei Gesellen + Fr?hlingsfahrt + + 01.01.1818 + 31.12.1818 + + + + + + + + + + + + + + + + + + 26.04.1564 + + + 23676 + + + 50431700 + + + + 7512400 + + + + + + + + + + + + + + 26.04.1564 + + + + + + + + + + + 01.01.1592 + 31.12.1593 + + + + + + + + + + 01.01.1597 + 31.12.1597 + + + + + + + + + + Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon Jul 27 03:18:41 2009 @@ -4,4 +4,28 @@ ;;+ ;;+ Isidorus is freely distributable under the LGPL license. ;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. -;;+----------------------------------------------------------------------------- \ No newline at end of file +;;+----------------------------------------------------------------------------- +(in-package :rdf-importer) + + +;(defun rdf-importer (rdf-xml-path repository-path +; &key +; (tm-id (error "you must provide a stable identifier (PSI-style) for this TM")) +; (document-id (get-uuid))) +; (unless (absolute-uri-p tm-id) +; (error "From rdf-impoert(): you must provide a stable identifier (PSI-style) for this TM")) +; (let ((rdf-dom +; (dom:document-element (cxml:parse-file +; (truename rdf-xml-path) +; (cxml-dom:make-dom-builder))))) +; (unless elephant:*store-controller* +; (elephant:open-store +; (get-store-spec repository-path))) +; (import-nodes rdf-dom :tm-id tm-id :document-id document-id)) +; (setf *arc-uuids* nil)) + + + + + + Added: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/rdf_tools.lisp Mon Jul 27 03:18:41 2009 @@ -0,0 +1,58 @@ +;;+----------------------------------------------------------------------------- +;;+ 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 :rdf-importer + (:use :cl :cxml :elephant :datamodel :isidorus-threading) + (:import-from :constants + *rdf-ns* + *rdfs-ns* + *xml-ns* + *xmlns-ns* + *xml-string*) + (:import-from :xml-constants + *core_psis.xtm*) + (:import-from :xml-tools + get-attribute + xpath-fn-string + xpath-child-elems-by-qname + xpath-single-child-elem-by-qname + xpath-select-location-path + xpath-select-single-location-path + get-ns-attribute + clear-child-nodes + has-qname + absolute-uri-p + get-node-name + child-nodes-or-text + get-xml-lang + get-xml-base + absolutize-value + concatenate-uri + push-string) + (:import-from :xml-importer + get-uuid + get-store-spec) + (:import-from :exceptions + missing-reference-error + duplicate-identifier-error)) + +(in-package :rdf-importer) + + +(defun _n-p (node-name) + "Returns t if the given value is of the form _[0-9]+" + (when (and node-name + (> (length node-name) 0) + (eql (elt node-name 0) #\_)) + (let ((rest + (subseq node-name 1 (length node-name)))) + (declare (string node-name)) + (handler-case (let ((int + (parse-integer rest))) + int) + (condition () nil))))) \ No newline at end of file Modified: trunk/src/xml/xtm/setup.lisp ============================================================================== --- trunk/src/xml/xtm/setup.lisp (original) +++ trunk/src/xml/xtm/setup.lisp Mon Jul 27 03:18:41 2009 @@ -38,7 +38,6 @@ (length (elephant:get-instances-by-class 'TopicC)) (length (elephant:get-instances-by-class 'AssociationC)))))) - (defun setup-repository (xtm-path repository-path &key tm-id Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Mon Jul 27 03:18:41 2009 @@ -14,10 +14,180 @@ :xpath-child-elems-by-qname :xpath-single-child-elem-by-qname :xpath-select-location-path - :xpath-select-single-location-path)) + :xpath-select-single-location-path + :get-ns-attribute + :clear-child-nodes + :absolute-uri-p + :get-node-name + :child-nodes-or-text + :get-xml-lang + :get-xml-base + :absolutize-value + :concatenate-uri + :push-string)) (in-package :xml-tools) +(defmacro push-string (obj place) + "Imitates the push macro but instead of pushing object in a list, + there will be appended the given string to the main string object." + `(setf ,place (concatenate 'string ,place ,obj))) + + +(defun concatenate-uri (absolute-ns value) + "Returns a string conctenated of the absolut namespace an the given value + separated by either '#' or '/'." + (declare (string absolute-ns value)) + (unless (or (> (length absolute-ns) 0) + (> (length value) 0)) + (error "From concatenate-uri(): absolute-ns and value must be of length > 0")) + (unless (absolute-uri-p absolute-ns) + (error "From concatenate-uri(): absolute-ns has to be an absolute URI: ~a" absolute-ns)) + (let ((last-char + (elt absolute-ns (- (length absolute-ns) 1)))) + (let ((separator + (cond + ((eql last-char #\#) + "#") + ((eql last-char #\/) + "/") + (t + "#"))) + (prep-ns + (if (or (eql last-char #\#) + (eql last-char #\/)) + (subseq absolute-ns 0 (- (length absolute-ns) 1)) + absolute-ns))) + (concatenate 'string prep-ns separator value)))) + + +(defun absolutize-value(value base tm-id) + "Returns the passed value as an absolute uri computed + with the given base and tm-id." + (declare (string value tm-id)) + (unless (absolute-uri-p tm-id) + (error "From absolutize-value(): you must provide a stable identifier (PSI-style) for this TM: ~a" tm-id)) + (when (> (count #\# value) 2) + (error "From absolutize-value(): value is allowed to have only one \"#\": ~a" value)) + (if (absolute-uri-p value) + value + (let ((prep-value + (if (> (length value) 0) + (string-left-trim "/" value) + "")) + (prep-base + (if (> (length base) 0) + (string-right-trim "/" base) + ""))) + (let ((fragment + (if (and (> (length prep-value) 0) + (eql (elt prep-value 0) #\#)) + (concatenate 'string prep-base prep-value) + (concatenate 'string prep-base "/" prep-value)))) + (if (absolute-uri-p fragment) + fragment + (let ((prep-fragment + (when (> (length fragment) 0) + (string-left-trim "/" fragment))) + (prep-tm-id + (when (> (length tm-id) 0) + (string-right-trim "/" tm-id)))) + (concatenate 'string prep-tm-id "/" prep-fragment))))))) + + +(defun get-xml-lang(elem &key (old-lang nil)) + "Computes the current xml-lang attribute and returns + its value as a string." + (declare (dom:element elem)) + (let ((new-lang + (get-ns-attribute elem *xml-ns* "lang"))) + (if (dom:has-attribute-ns elem *xml-ns* "lang") + new-lang + old-lang))) + + +(defun get-xml-base(elem &key (old-base nil)) + "Computes the current xml-base attribute and returns + its value as a string." + (declare (dom:element elem)) + (let ((new-base + (let ((inner-base + (if (find #\# (get-ns-attribute elem *xml-ns* "base")) + (error "From get-xml-base(): the base-uri ~a is not valid" + (get-ns-attribute elem *xml-ns* "base")) + (get-ns-attribute elem *xml-ns* "base")))) + (if (and (> (length inner-base) 0) + (eql (elt inner-base 0) #\/)) + (subseq inner-base 1 (length inner-base)) + inner-base)))) + + (if (or (absolute-uri-p new-base) + (not old-base)) + new-base + (if (not new-base) + old-base + (concatenate 'string (string-right-trim "/" old-base) + "/" (string-left-trim "/" new-base)))))) + + +(defun child-nodes-or-text (elem &key (trim nil)) + "Returns a list of dom-elements or a string. + Is there only one child which is not a text node it will be + returned as a list. Are only text nodes available their + results are concatenated and returned as a string. + comment nodes are removed anyway." + (declare (dom:element elem)) + (let ((children + (remove-if #'(lambda(node) + (when (dom:comment-p node) + t)) + (dom:child-nodes elem))) + (trim-fun (lambda(str) + (if trim + (string-trim '(#\Space #\Tab #\Newline) str) + str)))) + (if (find-if #'(lambda(node) + (unless (dom:text-node-p node) + t)) + children) + (remove-if #'(lambda(node) + (when (dom:text-node-p node) + (when (> (length + (string-trim '(#\Space #\Tab #\Newline) + (dom:node-value node))) + 0) + (error "Found literal content and xml-content in one node: ~a" + (dom:node-value node))) + t)) + children) + (let ((entire-string "")) + (map 'list #'(lambda(text-node) + (push-string (dom:node-value text-node) entire-string)) + children) + (if (> (length (apply trim-fun (list entire-string))) 0) + (apply trim-fun (list entire-string)) + nil))))) ;there were no text nodes available + + +(defun absolute-uri-p (uri) + "Returns t if the passed uri is an absolute one. This + is indicated by a ':' with no leadgin '/'." + (when uri + (let ((position-of-colon + (position #\: uri))) + (declare (string uri)) + (and position-of-colon (> position-of-colon 0) + (not (find #\/ (subseq uri 0 position-of-colon))))))) + + +(defun get-node-name (elem) + "Returns the node's name without a prefix." + (if (find #\: (dom:node-name elem)) + (subseq (dom:node-name elem) + (length (concatenate 'string (dom:prefix elem) ":"))) + (dom:node-name elem))) + + (defun conditional-fn (fn b) (if b fn @@ -130,3 +300,23 @@ ;;(defvar top (elt *topic-list* 501)) ;;(defvar scopes (xpath-select-location-path top '((*xtm-ns* "baseName") (*xtm-ns* "scope")))) +(defun get-ns-attribute (elem ns-uri name) + "Returns athe attributes value. If the value is + a string of the length 0, the return value is nil" + (declare (dom:element elem)) + (declare (string ns-uri name)) + (let ((attr + (dom:get-attribute-ns elem ns-uri name))) + (if (= (length attr) 0) + nil + attr))) + + +(defun clear-child-nodes (elem) + "Returns a list of child nodes, where all text-nodes and + all comment nodes are removed." + (declare (dom:element elem)) + (loop for child-node across (dom:child-nodes elem) + unless (or (dom:text-node-p child-node) + (dom:comment-p child-node)) + collect child-node)) \ No newline at end of file From lgiessmann at common-lisp.net Mon Jul 27 14:31:40 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 27 Jul 2009 10:31:40 -0400 Subject: [isidorus-cvs] r96 - in trunk/src: . unit_tests xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Mon Jul 27 10:31:40 2009 New Revision: 96 Log: added some basic helpers and a unit test file Added: trunk/src/unit_tests/rdf_importer_test.lisp Modified: trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Mon Jul 27 10:31:40 2009 @@ -25,7 +25,8 @@ :*rdfs-ns* :*xml-ns* :*xmlns-ns* - :*xml-string*)) + :*xml-string* + :*rdf2tm-ns*)) (in-package :constants) (defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/") @@ -60,4 +61,6 @@ (defparameter *xmlns-ns* "http://www.w3.org/2000/xmlns/") -(defparameter *xml-string* "http://www.w3.org/2001/XMLSchema#string") \ No newline at end of file +(defparameter *xml-string* "http://www.w3.org/2001/XMLSchema#string") + +(defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/") \ No newline at end of file Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Mon Jul 27 10:31:40 2009 @@ -133,7 +133,8 @@ :depends-on ("fixtures")) (:file "json_test" :depends-on ("fixtures")) - (:file "threading_test")) + (:file "threading_test") + (:file "rdf_importer_test")) :depends-on ("atom" "constants" "model" Added: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/rdf_importer_test.lisp Mon Jul 27 10:31:40 2009 @@ -0,0 +1,128 @@ +;;+----------------------------------------------------------------------------- +;;+ 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 :rdf-importer-test + (:use + :common-lisp + :xml-importer + :datamodel + :it.bese.FiveAM + :unittests-constants + :fixtures) + (:import-from :constants + *rdf-ns* + *rdfs-ns* + *rdf2tm-ns*) + (:import-from :xml-tools + xpath-child-elems-by-qname + xpath-single-child-elem-by-qname + xpath-select-location-path + get-ns-attribute) + (:export :test-get-literals-of-node + :test-parse-node + :run-rdf-importer-tests)) + +(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) + +(in-package :rdf-importer-test) + + +(def-suite importer-test + :description "tests various key functions of the importer") + +(in-suite importer-test) + + +(test test-get-literals-of-node + "Tests the helper function get-literals-of-node." + (let ((doc-1 + (concatenate 'string "")) + (doc-2 + (concatenate 'string ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) + (dom-2 (cxml:parse doc-2 (cxml-dom:make-dom-builder)))) + (is (= (length (dom:child-nodes dom-1)) 1)) + (is (= (length (dom:child-nodes dom-2)) 1)) + (let ((literals (rdf-importer::get-literals-of-node + (elt (dom:child-nodes dom-1) 0)))) + (is-true literals) + (is (= (length literals) 3)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "rdfUnknown") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "unknown")))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "isiID") + (string= (getf x :type) + "http://isidorus/test#ID"))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "isiArc") + (string= (getf x :type) + "http://isidorus/test#arc"))) + literals))) + (signals error (rdf-importer::get-literals-of-node + (elt (dom:child-nodes dom-2) 0)))))) + + +(test test-parse-node + "Tests the parse-node function." + (let ((doc-1 + (concatenate 'string "" + "" + "" + "" + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is (length (dom:child-nodes dom-1)) 1) + (let ((node (elt (dom:child-nodes dom-1) 0))) + (is-true (rdf-importer::parse-node node)) + (is-false (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)) + (dom:set-attribute-ns node *rdf-ns* "about" "rdfAbout") + (signals error (rdf-importer::parse-node node)) + (dom:set-attribute-ns node *rdf-ns* "nodeID" "rdfNodeID") + (signals error (rdf-importer::parse-node node)) + (dom:remove-attribute-ns node *rdf-ns* "about") + (signals error (rdf-importer::parse-node node)) + (dom:remove-attribute-ns node *rdf-ns* "ID") + (is-true (rdf-importer::parse-node node)) + (dom:set-attribute-ns node *rdf-ns* "about" "rdfAbout") + (signals error (rdf-importer::parse-node node)) + (is-false (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)) + (dom:remove-attribute-ns node *rdf-ns* "about") + (dom:remove-attribute-ns node *rdf-ns* "nodeID") + (is-true (rdf-importer::parse-node node)) + (is-true (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)) + (dom:replace-child node (dom:create-text-node dom-1 "anyText") + (xpath-single-child-elem-by-qname + node "http://test/arcs/" "rel")) + (signals error (rdf-importer::parse-node node)))))) + + + + + + +(defun run-rdf-importer-tests() + (it.bese.fiveam:run! 'test-get-literals-of-node) + (it.bese.fiveam:run! 'test-parse-node)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon Jul 27 10:31:40 2009 @@ -8,24 +8,51 @@ (in-package :rdf-importer) -;(defun rdf-importer (rdf-xml-path repository-path -; &key -; (tm-id (error "you must provide a stable identifier (PSI-style) for this TM")) -; (document-id (get-uuid))) -; (unless (absolute-uri-p tm-id) -; (error "From rdf-impoert(): you must provide a stable identifier (PSI-style) for this TM")) -; (let ((rdf-dom -; (dom:document-element (cxml:parse-file -; (truename rdf-xml-path) -; (cxml-dom:make-dom-builder))))) -; (unless elephant:*store-controller* -; (elephant:open-store -; (get-store-spec repository-path))) -; (import-nodes rdf-dom :tm-id tm-id :document-id document-id)) -; (setf *arc-uuids* nil)) - +(defvar *document-id* nil) +(defun tm-id-p (tm-id fun-name) + "Checks the validity of the passed tm-id." + (unless (absolute-uri-p tm-id) + (error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!" + fun-name tm-id))) + + +(defun rdf-importer (rdf-xml-path repository-path + &key + (tm-id nil) + (document-id (get-uuid))) + (setf *document-id* document-id) + (tm-id-p tm-id "rdf-importer") + (let ((rdf-dom + (dom:document-element (cxml:parse-file + (truename rdf-xml-path) + (cxml-dom:make-dom-builder))))) + (unless elephant:*store-controller* + (elephant:open-store + (get-store-spec repository-path))) + (import-dom rdf-dom :tm-id tm-id :document-id document-id))) +(defun import-dom (rdf-dom &key (tm-id nil) (document-id *document-id*)) + (tm-id-p tm-id "import-dom") + (let ((xml-base (get-xml-base rdf-dom)) + (xml-lang (get-xml-lang rdf-dom)) + (elem-name (get-node-name rdf-dom)) + (elem-ns (dom:namespace-uri rdf-dom))) + + (if (and (string= elem-ns *rdf-ns*) + (string= elem-name "RDF")) + (let ((children (child-nodes-or-text rdf-dom))) + (loop for child across children + do (import-node child tm-id :document-id document-id + :xml-base xml-base :xml-lang xml-lang))) + (import-node rdf-dom tm-id :document-id document-id + :xml-base xml-base :xml-lang xml-lang)))) + + +(defun import-node (elem tm-id &key (document-id *document-id*) + (xml-base nil) (xml-lang nil)) + (parse-node elem) + ) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Mon Jul 27 10:31:40 2009 @@ -13,7 +13,8 @@ *rdfs-ns* *xml-ns* *xmlns-ns* - *xml-string*) + *xml-string* + *rdf2tm-ns*) (:import-from :xml-constants *core_psis.xtm*) (:import-from :xml-tools @@ -55,4 +56,117 @@ (handler-case (let ((int (parse-integer rest))) int) - (condition () nil))))) \ No newline at end of file + (condition () nil))))) + + +(defun parse-node-name (node) + "Parses the given node's name to the known rdf/rdfs nodes and arcs. + If the given name es equal to a property an error is thrown otherwise + there is displayed a warning." + (declare (dom:element node)) + (let ((node-name (get-node-name node)) + (node-ns (dom:namespace-uri node))) + (when (string= node-ns *rdf-ns*) + (when (or (string= node-name "type") + (string= node-name "first") + (string= node-name "rest") + (string= node-name "subject") + (string= node-name "predicate") + (string= node-name "object")) + (error "From parse-node-name(): rdf:~a is a property and not allowed here!" + node-name)) + (when (string= node-name "RDF") + (error "From parse-node-name(): rdf:RDF not allowed here!")) + (unless (or (string= node-name "Description") + (string= node-name "List") + (string= node-name "Alt") + (string= node-name "Bag") + (string= node-name "Seq") + (string= node-name "Statement") + (string= node-name "Property") + (string= node-name "XMLLiteral")) + (format t "From parse-node-name(): Warning: ~a is not a known rdf:type!~%" + node-name))) + (when (string= node-ns *rdfs-ns*) + (when (or (string= node-name "subClassOf") + (string= node-name "subPropertyOf") + (string= node-name "domain") + (string= node-name "range") + (string= node-name "label") + (string= node-name "comment") + (string= node-name "member") + (string= node-name "seeAlso") + (string= node-name "isDefinedBy")) + (error "From parse-node-name(): rdfs:~a is a property and not allowed here!" + node-name)) + (unless (and (string= node-name "Resource") + (string= node-name "Literal") + (string= node-name "Class") + (string= node-name "Datatype") + (string= node-name "Cotnainer") + (string= node-name "ContainerMembershipProperty")) + (format t "From parse-node-name(): Warning: rdfs:~a is not a known rdfs:type!~%" + node-name)))) + t) + + +(defun parse-node(node) + "Parses a node that represents a rdf-resource." + (declare (dom:element node)) + (parse-node-name node) + (let ((ID (get-ns-attribute node "ID")) + (nodeID (get-ns-attribute node "nodeID")) + (about (get-ns-attribute node "about")) + (err-pref "From parse-node(): ")) + (when (and about nodeID) + (error "~ardf:about and rdf:nodeID are not allowed in parallel use: (~a) (~a)!" + err-pref about nodeID)) + (when (and ID + (or about nodeID)) + (error "~awhen rdf:ID is set the attributes rdf:~a is not allowed: ~a!" + err-pref (if about "about" "nodeID") (or about nodeID))) + (unless (or ID nodeID about) + (dom:set-attribute-ns node *rdf2tm-ns* "UUID" (get-uuid))) + (handler-case (let ((content (child-nodes-or-text node :trim t))) + (when (stringp content) + (error "text-content not allowed here!"))) + (condition (err) (error "~a~a" err-pref err)))) + t) + + + +(defun get-literals-of-node (node) + "Returns alist of attributes that are treated as literal nodes." + (let ((attributes nil)) + (dom:map-node-map + #'(lambda(attr) + (let ((attr-ns (dom:namespace-uri attr)) + (attr-name (get-node-name attr))) + (cond + ((string= attr-ns *rdf-ns*) + (unless (or (string= attr-name "ID") + (string= attr-name "about") + (string= attr-name "nodeID") + (string= attr-name "type")) + (push (list :type (concatenate-uri attr-ns attr-name) + :value (get-ns-attribute node attr-name)) + attributes))) + ((or (string= attr-ns *xml-ns*) + (string= attr-ns *xmlns-ns*)) + nil);;do nothing, all xml-attributes are no literals + ((string= attr-ns *rdfs-ns*) + (if (or (string= attr-name "subClassOf") + (string= attr-name "Class")) + (error "From get-literals-of-node(): rdfs:~a is not allowed here" + attr-name) + (push (list :type (concatenate-uri attr-ns attr-name) + :value (get-ns-attribute node attr-name + :ns-uri attr-ns)) + attributes))) + (t + (push (list :type (concatenate-uri attr-ns attr-name) + :value (get-ns-attribute node attr-name + :ns-uri attr-ns)) + attributes))))) + (dom:attributes node)) + attributes)) \ No newline at end of file Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Mon Jul 27 10:31:40 2009 @@ -9,6 +9,10 @@ (defpackage :xml-tools (:use :cl :cxml) + (:import-from :constants + *xml-ns* + *xmlns-ns* + *rdf-ns*) (:export :get-attribute :xpath-fn-string :xpath-child-elems-by-qname @@ -100,7 +104,7 @@ its value as a string." (declare (dom:element elem)) (let ((new-lang - (get-ns-attribute elem *xml-ns* "lang"))) + (get-ns-attribute elem "lang" :ns-uri *xml-ns*))) (if (dom:has-attribute-ns elem *xml-ns* "lang") new-lang old-lang))) @@ -112,10 +116,10 @@ (declare (dom:element elem)) (let ((new-base (let ((inner-base - (if (find #\# (get-ns-attribute elem *xml-ns* "base")) + (if (find #\# (get-ns-attribute elem "base" :ns-uri *xml-ns*)) (error "From get-xml-base(): the base-uri ~a is not valid" (get-ns-attribute elem *xml-ns* "base")) - (get-ns-attribute elem *xml-ns* "base")))) + (get-ns-attribute elem "base" :ns-uri *xml-ns*)))) (if (and (> (length inner-base) 0) (eql (elt inner-base 0) #\/)) (subseq inner-base 1 (length inner-base)) @@ -300,7 +304,7 @@ ;;(defvar top (elt *topic-list* 501)) ;;(defvar scopes (xpath-select-location-path top '((*xtm-ns* "baseName") (*xtm-ns* "scope")))) -(defun get-ns-attribute (elem ns-uri name) +(defun get-ns-attribute (elem name &key (ns-uri *rdf-ns*)) "Returns athe attributes value. If the value is a string of the length 0, the return value is nil" (declare (dom:element elem)) From lgiessmann at common-lisp.net Wed Jul 29 14:53:57 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 29 Jul 2009 10:53:57 -0400 Subject: [isidorus-cvs] r97 - in trunk: docs src src/unit_tests src/xml/rdf src/xml/xtm Message-ID: Author: lgiessmann Date: Wed Jul 29 10:53:52 2009 New Revision: 97 Log: added some basic functions and unit tests for the rdf-importer Modified: trunk/docs/json.ebnf trunk/src/isidorus.asd trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/tools.lisp Modified: trunk/docs/json.ebnf ============================================================================== --- trunk/docs/json.ebnf (original) +++ trunk/docs/json.ebnf Wed Jul 29 10:53:52 2009 @@ -41,14 +41,14 @@ Scope = "\"scopes\":" (DblList | Null) InstanceOf = "\"instanceOfs\":" (DblList | Null) Type = "\"type\":" List -ID = "\id\":" string +ID = "\id\":" String TopicRef = "\"topicRef\":" List Variant = "{" ItemIdentity "," Scope "," RData "}" Variants = "\"variants\":" (("[" Variant+ "]") | Null) Name = "{" ItemIdentity "," Type "," Scope "," Value "," Variants "}" -Names = "\"names\":" ("[" Name+ "]") | Null +Names = "\"names\":" (("[" Name+ "]") | Null) Occurrence = "{" ItemIdentity "," Type "," Scope "," RData "}" Occurrences = "\"occurrences\":" (("[" Occurrence+ "]") | Null) @@ -60,7 +60,7 @@ Roles = "\"roles\":" (("[" Role+ "]") | Null) Association = "{" ItemIdentity "," Type "," Scope "," Roles "}" -Associations "\"associations\":" (("[" Association "]") | Null) +Associations = "\"associations\":" (("[" Association "]") | Null) TopicStub = "{" ID "," ItemIdentity "," SubjectLocator "," SubjectIdentifier "}" TopicStubs = "\"topicStubs\":" (("[" TopicStub+ "]") | Null) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Jul 29 10:53:52 2009 @@ -134,7 +134,8 @@ (:file "json_test" :depends-on ("fixtures")) (:file "threading_test") - (:file "rdf_importer_test")) + (:file "rdf_importer_test" + :depends-on ("fixtures"))) :depends-on ("atom" "constants" "model" 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 Wed Jul 29 10:53:52 2009 @@ -13,17 +13,19 @@ :xml-importer :datamodel :it.bese.FiveAM - :unittests-constants :fixtures) (:import-from :constants *rdf-ns* *rdfs-ns* - *rdf2tm-ns*) + *rdf2tm-ns* + *xml-ns* + *xml-string*) (:import-from :xml-tools xpath-child-elems-by-qname xpath-single-child-elem-by-qname xpath-select-location-path - get-ns-attribute) + get-ns-attribute + absolute-uri-p) (:export :test-get-literals-of-node :test-parse-node :run-rdf-importer-tests)) @@ -46,53 +48,97 @@ "xmlns:isi=\"http://isidorus/test#\" " "rdf:type=\"rdfType\" rdf:ID=\"rdfID\" rdf:nodeID=\"" "rdfNodeID\" rdf:unknown=\"rdfUnknown\" " - "isi:ID=\"isiID\" isi:arc=\"isiArc\"/>")) - (doc-2 - (concatenate 'string ""))) - (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) - (dom-2 (cxml:parse doc-2 (cxml-dom:make-dom-builder)))) + "isi:ID=\"isiID\" isi:arc=\"isiArc\" " + "isi:empty=\"\"/>"))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is (= (length (dom:child-nodes dom-1)) 1)) + (let ((literals (rdf-importer::get-literals-of-node + (elt (dom:child-nodes dom-1) 0) nil))) + (is-true literals) + (is (= (length literals) 4)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "rdfUnknown") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "unknown")) + (not (getf x :ID)))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "isiID") + (string= (getf x :type) + "http://isidorus/test#ID") + (not (getf x :ID)))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "isiArc") + (string= (getf x :type) + "http://isidorus/test#arc") + (not (getf x :ID)))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "") + (string= (getf x :type) + "http://isidorus/test#empty") + (not (getf x :ID)))) + literals)) + (map 'list #'(lambda(x) (is-false (getf x :lang))) + literals))) + + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is (= (length (dom:child-nodes dom-1)) 1)) - (is (= (length (dom:child-nodes dom-2)) 1)) + (dom:set-attribute-ns (elt (dom:child-nodes dom-1) 0) + *xml-ns* "lang" "de") (let ((literals (rdf-importer::get-literals-of-node - (elt (dom:child-nodes dom-1) 0)))) + (elt (dom:child-nodes dom-1) 0) "en"))) (is-true literals) - (is (= (length literals) 3)) + (is (= (length literals) 4)) (is-true (find-if #'(lambda(x) (and (string= (getf x :value) "rdfUnknown") (string= (getf x :type) - (concatenate 'string *rdf-ns* "unknown")))) + (concatenate 'string *rdf-ns* "unknown")) + (not (getf x :ID)))) literals)) (is-true (find-if #'(lambda(x) (and (string= (getf x :value) "isiID") (string= (getf x :type) - "http://isidorus/test#ID"))) + "http://isidorus/test#ID") + (not (getf x :ID)))) literals)) (is-true (find-if #'(lambda(x) (and (string= (getf x :value) "isiArc") (string= (getf x :type) - "http://isidorus/test#arc"))) - literals))) - (signals error (rdf-importer::get-literals-of-node - (elt (dom:child-nodes dom-2) 0)))))) + "http://isidorus/test#arc") + (not (getf x :ID)))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "") + (string= (getf x :type) + "http://isidorus/test#empty") + (not (getf x :ID)))) + literals)) + (map 'list #'(lambda(x) (is-true (string= (getf x :lang) "de"))) + literals))))) (test test-parse-node "Tests the parse-node function." (let ((doc-1 - (concatenate 'string "" "" - "" + "" "" - ""))) + ""))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is (length (dom:child-nodes dom-1)) 1) (let ((node (elt (dom:child-nodes dom-1) 0))) @@ -113,16 +159,400 @@ (dom:remove-attribute-ns node *rdf-ns* "nodeID") (is-true (rdf-importer::parse-node node)) (is-true (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)) + (dom:set-attribute-ns node *rdf-ns* "resource" "rdfResource") + (signals error (rdf-importer::parse-node node)) + (dom:set-attribute-ns node *rdf-ns* "resource" "") + (is-true (rdf-importer::parse-node node)) (dom:replace-child node (dom:create-text-node dom-1 "anyText") (xpath-single-child-elem-by-qname node "http://test/arcs/" "rel")) (signals error (rdf-importer::parse-node node)))))) +(test test-get-literals-of-property + "Tests the function get-literals-or-property." + (let ((doc-1 + (concatenate 'string "content-text"))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)) 1)) + (let ((property (elt (dom:child-nodes dom-1) 0))) + (let ((literals (rdf-importer::get-literals-of-property property nil))) + (is (= (length literals) 3)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) + "http://should/be/a/literal") + (string= (getf x :type) "http://props/prop1") + (not (getf x :ID)))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "prop-2") + (string= (getf x :type) "http://props/prop2") + (not (getf x :ID)))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "") + (string= (getf x :type) "http://props/prop3") + (not (getf x :ID)))) + literals))))))) + + +(test test-parse-property + "Tests the function parse-property." + (let ((doc-1 + (concatenate 'string "" + "" + "" + "" + "" + "" + "content-text" + "" + "" + "" + "" + "" + "" + "" + "" + "prop6" + "" + "" + " " + "" + " " + "" + " " + "" + "prop14" + "" + "" + " " + "" + " " + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)) 1)) + (let ((child (elt (dom:child-nodes dom-1) 0))) + (let ((children (rdf-importer::child-nodes-or-text child)) + (text-node (dom:create-text-node dom-1 "new text node"))) + (is (= (length children) 19)) + (loop for property across children + do (is-true (rdf-importer::parse-property property))) + (dotimes (i (length children)) + (if (or (= i 0) (= i 1) (= i 3) (= i 4) (= i 9) (= i 17)) + (is-true (get-ns-attribute (elt children i) "UUID" + :ns-uri *rdf2tm-ns*)) + (is-false (get-ns-attribute (elt children i) "UUID" + :ns-uri *rdf2tm-ns*)))) + (let ((prop (elt children 0))) + (dom:set-attribute-ns prop *rdf-ns* "parseType" "Unknown") + (signals error (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "parseType" "Resource") + (is-true (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "ID" "newID") + (is-true (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "bad" "bad") + (signals error (rdf-importer::parse-property prop)) + (dom:remove-attribute-ns prop *rdf-ns* "bad") + (is-true (rdf-importer::parse-property prop)) + (dom:append-child prop text-node) + (signals error (rdf-importer::parse-property prop)) + (dom:remove-child prop text-node) + (is-true (rdf-importer::parse-property prop))) + (let ((prop (elt children 1))) + (dom:set-attribute-ns prop *rdf-ns* "nodeID" "bad") + (signals error (rdf-importer::parse-property prop)) + (dom:remove-attribute-ns prop *rdf-ns* "nodeID") + (is-true (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "ID" "newID") + (is-true (rdf-importer::parse-property prop)) + (dom:append-child prop text-node) + (signals error (rdf-importer::parse-property prop)) + (dom:remove-child prop text-node) + (is-true (rdf-importer::parse-property prop))) + (let ((prop (elt children 3))) + (dom:append-child prop text-node) + (signals error (rdf-importer::parse-property prop)) + (dom:remove-child prop text-node) + (is-true (rdf-importer::parse-property prop))) + (let ((prop (elt children 4))) + (dom:append-child prop text-node) + (signals error (rdf-importer::parse-property prop)) + (dom:remove-child prop text-node) + (is-true (rdf-importer::parse-property prop))) + (let ((prop (elt children 5))) + (dom:set-attribute-ns prop *rdf-ns* "type" "newType") + (is-true (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "unknown" "unknown") + (is-true (rdf-importer::parse-property prop)) + (dom:append-child prop text-node) + (signals error (rdf-importer::parse-property prop)) + (dom:remove-child prop text-node) + (is-true (rdf-importer::parse-property prop)) + (dom:remove-attribute-ns prop *rdf-ns* "unknown") + (is-true (rdf-importer::parse-property prop)) + (dom:append-child prop text-node) + (signals error (rdf-importer::parse-property prop)) + (dom:remove-child prop text-node) + (is-true (rdf-importer::parse-property prop))) + (let ((prop (elt children 10))) + (dom:set-attribute-ns prop *rdf-ns* "type" "newType") + (signals error (rdf-importer::parse-property prop)) + (dom:remove-attribute-ns prop *rdf-ns* "type") + (is-true (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "nodeID" "newNodeID") + (signals error (rdf-importer::parse-property prop)) + (dom:remove-attribute-ns prop *rdf-ns* "nodeID") + (is-true (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "resource" "newResource") + (signals error (rdf-importer::parse-property prop)) + (dom:remove-attribute-ns prop *rdf-ns* "resource") + (is-true (rdf-importer::parse-property prop)) + (dom:set-attribute-ns prop *rdf-ns* "ID" "newID") + (is-true (rdf-importer::parse-property prop)))))))) + + +(test test-get-types + "Tests the functions get-type-of-node-name, get-types-of-content, + get-node-rerfs, absolute-uri-p, absolutize-value and absolutize-id." + (let ((tm-id "http://test-tm") + (doc-1 + (concatenate 'string "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + + "" + "" + "" + "" + "" + "" + "" + "" + "" + + "" + "" + "" + "" + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)) 1)) + (is-true (absolute-uri-p tm-id)) + (is-false (absolute-uri-p "http//bad")) + (is-false (absolute-uri-p "")) + (is-false (absolute-uri-p " ")) + (is-false (absolute-uri-p nil)) + (let ((node (elt (dom:child-nodes dom-1) 0))) + (loop for property across (rdf-importer::child-nodes-or-text node) + do (rdf-importer::parse-property property)) + (let ((types + (append + (list (list + :value (rdf-importer::get-type-of-node-name node) + :ID nil)) + (rdf-importer::get-types-of-node-content node tm-id nil))) + (node-uuid (get-ns-attribute + (elt (rdf-importer::child-nodes-or-text + (elt (rdf-importer::child-nodes-or-text node) 7)) + 0) + "UUID" :ns-uri *rdf2tm-ns*))) + (is (= (length types) 10)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) + (concatenate + 'string *rdf-ns* "anyType")) + (not (getf x :ID)))) + types)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) + (concatenate + 'string tm-id + "/xml-base/first/attr-type")) + (not (getf x :ID)))) + types)) + (is-true (find-if #'(lambda(x) + (and (string= + (getf x :value) + (concatenate + 'string tm-id + "/xml-base/first/content-type-1")) + (string= (getf x :ID) + "rdfID"))) + types)) + (is-true (find-if #'(lambda(x) + (and (string= + (getf x :value) + (concatenate + 'string tm-id + "/xml-base/first/c-about-type-2")) + (string= (getf x :ID) + "rdfID2"))) + types)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) + "c-nodeID-type-2") + (not (getf x :ID)))) + types)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) + "http://new-base#c-ID-type-2") + (not (getf x :ID)))) + types)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) node-uuid) + (string= (getf x :ID) + "rdfID3"))) + types)) + (is-true (= 10 (count-if #'(lambda(x) + (> (length (getf x :value)) 0)) + types)))))))) +(test test-get-literals-of-content + (let ((doc-1 + (concatenate 'string "" + "text0" + "text1" + "text2" + "" + "" + "" + "" + " " + "" + "childText5 " + "" + " abc " + "" + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) + (tm-id "http://test-tm")) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)) 1)) + (let ((node (elt (dom:child-nodes dom-1) 0))) + (dotimes (iter (length (dom:child-nodes node))) + (is-true (rdf-importer::parse-property + (elt (dom:child-nodes node) iter)))) + (let ((literals (rdf-importer::get-literals-of-node-content + node tm-id nil nil))) + (is (= (length literals) 7)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) "text0") + (string= (getf x :type) + "http://isidorus/props/lit0") + (not (getf x :ID)) + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*))) + literals)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) "text1") + (string= (getf x :type) + "http://isidorus/props/lit1") + (not (getf x :ID)) + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*))) + literals)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) "text2") + (string= (getf x :type) + "http://isidorus/props/lit2") + (not (getf x :ID)) + (string= (getf x :lang) "de") + (string= (getf x :datatype) + "http://base/absolute/dType1"))) + literals)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) "text3") + (string= (getf x :type) + "http://isidorus/props/lit3") + (not (getf x :ID)) + (string= (getf x :lang) "en") + (string= (getf x :datatype) + "http://test-tm/base/first/dType2"))) + literals)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) + " ") + (string= (getf x :type) + "http://isidorus/props/lit4") + (not (getf x :ID)) + (string= (getf x :lang) "de") + (string= (getf x :datatype) + "http://test-tm/base/first/dType2"))) + literals)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) + "childText5 ") + (string= (getf x :type) + "http://isidorus/props/lit5") + (string= (getf x :ID) "rdfID") + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*))) + literals)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) " text6 abc ") + (string= (getf x :type) + "http://isidorus/props/lit6") + (not (getf x :ID)) + (not (getf x :lang)) + (string= (getf x :datatype) *xml-string*))) + literals))))))) (defun run-rdf-importer-tests() (it.bese.fiveam:run! 'test-get-literals-of-node) - (it.bese.fiveam:run! 'test-parse-node)) \ No newline at end of file + (it.bese.fiveam:run! 'test-parse-node) + (it.bese.fiveam:run! 'test-get-literals-of-property) + (it.bese.fiveam:run! 'test-parse-property) + (it.bese.fiveam:run! 'test-get-types) + (it.bese.fiveam:run! 'test-get-literals-of-content)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Jul 29 10:53:52 2009 @@ -54,5 +54,217 @@ (defun import-node (elem tm-id &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) + (declare (ignorable document-id)) ;TODO: remove + (tm-id-p tm-id "import-node") (parse-node elem) - ) \ No newline at end of file + (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) + (loop for property across (child-nodes-or-text elem) + do (parse-property property)) + (let ((about + (if (get-ns-attribute elem "about") + (absolutize-value (get-ns-attribute elem "about") + fn-xml-base tm-id) + nil)) + (nodeID (get-ns-attribute elem "nodeID")) + (ID (get-ns-attribute elem "ID")) + (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) + (literals (append (get-literals-of-node elem xml-lang) + (get-literals-of-node-content elem tm-id + xml-base xml-lang))) + (associations nil) + (types (append (list + (list :value (get-type-of-node-name elem) :ID nil)) + (get-types-of-node-content elem tm-id fn-xml-base))) + (super-classes nil)) ;TODO: implement + (declare (ignorable about nodeID ID UUID literals associations ;TODO: remove + types super-classes))))) + + +(defun get-literals-of-node-content (node tm-id xml-base xml-lang) + "Returns a list of literals that is produced of a node's content." + (declare (dom:element node)) + (tm-id-p tm-id "get-literals-of-content") + (let ((properties (child-nodes-or-text node)) + (fn-xml-base (get-xml-base node :old-base xml-base)) + (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) + (let ((literals + (loop for property across properties + when (let ((prp-xml-base (get-xml-base property + :old-base fn-xml-base))) + (let ((datatype + (when (get-ns-attribute property "datatype") + (absolutize-value + (get-ns-attribute property "datatype") + prp-xml-base tm-id))) + (parseType (get-ns-attribute property "parseType")) + (nodeID (get-ns-attribute property "nodeID")) + (resource (get-ns-attribute property "resource")) + (UUID (get-ns-attribute property "UUID" + :ns-uri *rdf2tm-ns*))) + (or (or datatype + (string= parseType "Literal")) + (not (or nodeID resource UUID parseType))))) + collect (let ((content (child-nodes-or-text property)) + (prp-xml-base (get-xml-base property + :old-base fn-xml-base)) + (ID (get-ns-attribute property "ID")) + (prp-name (get-node-name property)) + (prp-ns (dom:namespace-uri property)) + (child-xml-lang + (get-xml-lang property :old-lang fn-xml-lang))) + (let ((full-name (concatenate-uri prp-ns prp-name)) + (datatype + (if (get-ns-attribute property "datatype") + (absolutize-value + (get-ns-attribute property "datatype") + prp-xml-base tm-id) + *xml-string*)) + (text + (cond + ((= (length content) 0) + "") + ((not (stringp content)) ;must be an element + (let ((text-val "")) + (loop for content-node across + (dom:child-nodes property) + do (push-string + (node-to-string content-node) + text-val)) + text-val)) + (t content)))) + (list :type full-name + :value text + :ID ID + :lang child-xml-lang + :datatype datatype)))))) + + literals))) + + +(defun get-type-of-node-name (node) + "Returns the type of the node name (namespace + tagname)." + (let ((node-name (get-node-name node)) + (node-ns (dom:namespace-uri node))) + (concatenate-uri node-ns node-name))) + + +(defun get-types-of-node-content (node tm-id xml-base) + "Returns a list of type-uris that corresponds to the node's content + or attributes." + (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + (let ((attr-type + (if (get-ns-attribute node "type") + (list + (list :value (absolutize-value (get-ns-attribute node "type") + fn-xml-base tm-id) + :ID nil)) + nil)) + (content-types + (loop for child across (child-nodes-or-text node) + when (and (string= (dom:namespace-uri child) *rdf-ns*) + (string= (get-node-name child) "type")) + collect (let ((nodeID (get-ns-attribute child "nodeID")) + (resource (if (get-ns-attribute child "resource") + (absolutize-value + (get-ns-attribute child "resource") + fn-xml-base tm-id))) + (UUID (get-ns-attribute child "UUID" + :ns-uri *rdf2tm-ns*)) + (ID (get-ns-attribute child "ID"))) + (if (or nodeID resource UUID) + (list :value (or nodeID resource UUID) + :ID ID) + (let ((child-xml-base + (get-xml-base child :old-base fn-xml-base))) + (loop for ref in + (get-node-refs (child-nodes-or-text child) + tm-id child-xml-base) + append (list :value ref + :ID ID)))))))) + (remove-if #'null (append attr-type content-types))))) + + +(defun get-literals-of-property (property xml-lang) + "Returns a list of attributes that are treated as literal nodes." + (let ((fn-xml-lang (get-xml-lang property :old-lang xml-lang)) + (attributes nil)) + (dom:map-node-map + #'(lambda(attr) + (let ((attr-ns (dom:namespace-uri attr)) + (attr-name (get-node-name attr))) + (let ((l-type (concatenate-uri attr-ns attr-name)) + (l-value (if (get-ns-attribute property attr-name + :ns-uri attr-ns) + (get-ns-attribute property attr-name + :ns-uri attr-ns) + ""))) + (cond + ((string= attr-ns *rdf-ns*) + (unless (or (string= attr-name "ID") + (string= attr-name "resource") + (string= attr-name "nodeID") + (string= attr-name "type") + (string= attr-name "parseType") + (string= attr-name "datatype")) + (push (list :type l-type + :value l-value + :ID nil + :lang fn-xml-lang + :datatype *xml-string*) + attributes))) + ((or (string= attr-ns *xml-ns*) + (string= attr-ns *xmlns-ns*)) + nil);;do nothing, all xml-attributes are no literals + (t + (unless (and (string= attr-ns *rdf2tm-ns*) + (string= attr-name "UUID")) + (push (list :type l-type + :value l-value + :ID nil + :lang fn-xml-lang + :datatype *xml-string*) + attributes))))))) + (dom:attributes property)) + attributes)) + + +(defun get-literals-of-node (node xml-lang) + "Returns alist of attributes that are treated as literal nodes." + (let ((fn-xml-lang (get-xml-lang node :old-lang xml-lang)) + (attributes nil)) + (dom:map-node-map + #'(lambda(attr) + (let ((attr-ns (dom:namespace-uri attr)) + (attr-name (get-node-name attr))) + (let ((l-type (concatenate-uri attr-ns attr-name)) + (l-value (if (get-ns-attribute node attr-name :ns-uri attr-ns) + (get-ns-attribute node attr-name :ns-uri attr-ns) + ""))) + (cond + ((string= attr-ns *rdf-ns*) + (unless (or (string= attr-name "ID") + (string= attr-name "about") + (string= attr-name "nodeID") + (string= attr-name "type")) + (push (list :type l-type + :value l-value + :ID nil + :lang fn-xml-lang + :datatype *xml-string*) + attributes))) + ((or (string= attr-ns *xml-ns*) + (string= attr-ns *xmlns-ns*)) + nil);;do nothing, all xml-attributes are no literals + (t + (unless (and (string= attr-ns *rdf2tm-ns*) + (string= attr-name "UUID")) + (push (list :type l-type + :value l-value + :ID nil + :lang fn-xml-lang + :datatype *xml-string*) + attributes))))))) + (dom:attributes node)) + attributes)) + + Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Wed Jul 29 10:53:52 2009 @@ -33,8 +33,10 @@ get-xml-lang get-xml-base absolutize-value + absolutize-id concatenate-uri - push-string) + push-string + node-to-string) (:import-from :xml-importer get-uuid get-store-spec) @@ -44,6 +46,18 @@ (in-package :rdf-importer) +(defvar *rdf-types* (list "Description" "List" "Alt" "Bag" "Seq" + "Statement" "Property" "XMLLiteral")) + +(defvar *rdf-properties* (list "type" "first" "rest" "subject" "predicate" + "object")) + +(defvar *rdfs-types* (list "Resource" "Literal" "Class" "Datatype" + "Container" "ContainerMembershipProperty")) + +(defvar *rdfs-properties* (list "subClassOf" "subPropertyOf" "domain" + "range" "range" "label" "comment" + "member" "seeAlso" "isDefinedBy")) (defun _n-p (node-name) "Returns t if the given value is of the form _[0-9]+" @@ -62,51 +76,28 @@ (defun parse-node-name (node) "Parses the given node's name to the known rdf/rdfs nodes and arcs. If the given name es equal to a property an error is thrown otherwise - there is displayed a warning." + there is displayed a warning when the rdf ord rdfs namespace is used." (declare (dom:element node)) (let ((node-name (get-node-name node)) - (node-ns (dom:namespace-uri node))) + (node-ns (dom:namespace-uri node)) + (err-pref "From parse-node-name(): ")) (when (string= node-ns *rdf-ns*) - (when (or (string= node-name "type") - (string= node-name "first") - (string= node-name "rest") - (string= node-name "subject") - (string= node-name "predicate") - (string= node-name "object")) - (error "From parse-node-name(): rdf:~a is a property and not allowed here!" - node-name)) + (when (find node-name *rdf-properties* :test #'string=) + (error "~ardf:~a is a property and not allowed here!" + err-pref node-name)) (when (string= node-name "RDF") - (error "From parse-node-name(): rdf:RDF not allowed here!")) - (unless (or (string= node-name "Description") - (string= node-name "List") - (string= node-name "Alt") - (string= node-name "Bag") - (string= node-name "Seq") - (string= node-name "Statement") - (string= node-name "Property") - (string= node-name "XMLLiteral")) - (format t "From parse-node-name(): Warning: ~a is not a known rdf:type!~%" - node-name))) + (error "~ardf:RDF not allowed here!" + err-pref)) + (unless (find node-name *rdf-types* :test #'string=) + (format t "~aWarning: ~a is not a known RDF type!~%" + err-pref node-name))) (when (string= node-ns *rdfs-ns*) - (when (or (string= node-name "subClassOf") - (string= node-name "subPropertyOf") - (string= node-name "domain") - (string= node-name "range") - (string= node-name "label") - (string= node-name "comment") - (string= node-name "member") - (string= node-name "seeAlso") - (string= node-name "isDefinedBy")) - (error "From parse-node-name(): rdfs:~a is a property and not allowed here!" - node-name)) - (unless (and (string= node-name "Resource") - (string= node-name "Literal") - (string= node-name "Class") - (string= node-name "Datatype") - (string= node-name "Cotnainer") - (string= node-name "ContainerMembershipProperty")) - (format t "From parse-node-name(): Warning: rdfs:~a is not a known rdfs:type!~%" - node-name)))) + (when (find node-name *rdfs-properties* :test #'string=) + (error "~ardfs:~a is a property and not allowed here!" + err-pref node-name)) + (unless (find node-name *rdfs-types* :test #'string=) + (format t "~aWarning: rdfs:~a is not a known rdfs:type!~%" + err-pref node-name)))) t) @@ -117,7 +108,12 @@ (let ((ID (get-ns-attribute node "ID")) (nodeID (get-ns-attribute node "nodeID")) (about (get-ns-attribute node "about")) - (err-pref "From parse-node(): ")) + (err-pref "From parse-node(): ") + (resource (get-ns-attribute node "resource")) + (datatype (get-ns-attribute node "datatype")) + (parseType (get-ns-attribute node "parseType")) + (class (get-ns-attribute node "Class" :ns-uri *rdfs-ns*)) + (subClassOf (get-ns-attribute node "subClassOf" :ns-uri *rdfs-ns*))) (when (and about nodeID) (error "~ardf:about and rdf:nodeID are not allowed in parallel use: (~a) (~a)!" err-pref about nodeID)) @@ -130,43 +126,161 @@ (handler-case (let ((content (child-nodes-or-text node :trim t))) (when (stringp content) (error "text-content not allowed here!"))) - (condition (err) (error "~a~a" err-pref err)))) + (condition (err) (error "~a~a" err-pref err))) + (when (or resource datatype parseType class subClassOf) + (error "~a~a is not allowed here!" + err-pref (cond + (resource (concatenate 'string "resource(" + resource ")")) + (datatype (concatenate 'string "datatype(" + datatype ")")) + (parseType (concatenate 'string "parseType(" + parseType ")")) + (class (concatenate 'string "Class(" class ")")) + (subClassOf (concatenate 'string "subClassOf(" + subClassOf ")"))))) + (dolist (item *rdf-types*) + (when (get-ns-attribute node item) + (error "~ardf:~a is a type and not allowed here!" + err-pref item))) + (dolist (item *rdfs-types*) + (when (get-ns-attribute node item :ns-uri *rdfs-ns*) + (error "~ardfs:~a is a type and not allowed here!" + err-pref item)))) t) +(defun get-node-refs (nodes tm-id xml-base) + "Returns a list of node references that can be used as topic IDs." + (when (and nodes + (> (length nodes) 0)) + (loop for node across nodes + collect (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + (parse-node node) + (let ((ID (when (get-ns-attribute node "ID") + (absolutize-id (get-ns-attribute node "ID") + fn-xml-base tm-id))) + (nodeID (get-ns-attribute node "nodeID")) + (about (when (get-ns-attribute node "about") + (absolutize-value + (get-ns-attribute node "about") + fn-xml-base tm-id))) + (UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*))) + (or ID nodeID about UUID)))))) + + +(defun parse-property-name (property) + "Parses the given property's name to the known rdf/rdfs nodes and arcs. + If the given name es equal to an node an error is thrown otherwise + there is displayed a warning when the rdf ord rdfs namespace is used." + (declare (dom:element property)) + (let ((property-name (get-node-name property)) + (property-ns (dom:namespace-uri property)) + (err-pref "From parse-property-name(): ")) + (when (string= property-ns *rdf-ns*) + (when (find property-name *rdf-types* :test #'string=) + (error "~ardf:~a is a node and not allowed here!" + err-pref property-name)) + (when (string= property-name "RDF") + (error "~ardf:RDF not allowed here!" + err-pref)) + (unless (find property-name *rdf-properties* :test #'string=) + (format t "~aWarning: ~a is not a known RDF property!~%" + err-pref property-name))) + (when (string= property-ns *rdfs-ns*) + (when (find property-name *rdfs-types* :test #'string=) + (error "~ardfs:~a is a type and not allowed here!" + err-pref property-name)) + (unless (find property-name *rdfs-properties* :test #'string=) + (format t "~aWarning: rdfs:~a is not a known rdfs:type!~%" + err-pref property-name)))) + t) + + +(defun parse-property (property) + "Parses a property that represents a rdf-arc." + (declare (dom:element property)) + (let ((err-pref "From parse-property(): ") + (node-name (get-node-name property)) + (node-ns (dom:namespace-uri property)) + (nodeID (get-ns-attribute property "nodeID")) + (resource (get-ns-attribute property "resource")) + (datatype (get-ns-attribute property "datatype")) + (type (get-ns-attribute property "type")) + (parseType (get-ns-attribute property "parseType")) + (about (get-ns-attribute property "about")) + (subClassOf (get-ns-attribute property "subClassOf" :ns-uri *rdfs-ns*)) + (literals (get-literals-of-property property nil)) + (content (child-nodes-or-text property :trim t))) + (when (and parseType + (or nodeID resource datatype type literals)) + (error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!" + err-pref + (append (list (cond (nodeID "rdf:nodeID") + (resource "rdf:resource") + (datatype "rdf:datatype") + (type "rdf:type"))) + (map 'list #'(lambda(x)(getf x :type)) literals)) + (append (list (or nodeID resource datatype type)) + (map 'list #'(lambda(x)(getf x :value)) literals)))) + (when (and parseType + (not (or (string= parseType "Resource") + (string= parseType "Literal") + (string= parseType "Collection")))) + (error "~aunknown rdf:parseType: ~a" + err-pref parseType)) + (when (and parseType + (or (string= parseType "Resource") + (string= parseType "Collection"))) + (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))) + (when (and parseType (string= parseType "Resource") (stringp content)) + (error "~ardf:parseType is set to 'Resource' expecting xml content: ~a!" + err-pref content)) + (when (and parseType + (string= parseType "Collection") + (stringp content)) + (error "~ardf:parseType is set to 'Collection' expecting resource content: ~a" + err-pref content)) + (when (and nodeID resource) + (error "~aondly one of rdf:nodeID and rdf:resource is allowed: (~a) (~a)!" + err-pref nodeID resource)) + (when (and (or nodeID resource type) + datatype) + (error "~aonly one of ~a and rdf:datatype (~a) is allowed!" + err-pref + (cond + (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")")) + (resource (concatenate 'string "rdf:resource (" resource ")")) + (type (concatenate 'string "rdf:type (" type ")"))) + datatype)) + (when (and (or type nodeID resource) + (> (length content) 0)) + (error "~awhen ~a is set no content is allowed: ~a!" + err-pref + (cond + (type (concatenate 'string "rdf:type (" type ")")) + (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")")) + (resource (concatenate 'string "rdf:resource (" resource ")"))) + content)) + (when (and (or type + (and (string= node-name "type") + (string= node-ns *rdf-ns*))) + (not (or nodeID resource)) + (not content)) + (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))) + (when (or about subClassOf) + (error "~a~a not allowed here!" + err-pref + (if about + (concatenate 'string "rdf:about (" about ")") + (concatenate 'string "rdfs:subClassOf (" subClassOf ")")))) + (dolist (item *rdf-types*) + (when (get-ns-attribute property item) + (error "~ardf:~a is a type and not allowed here!" + err-pref item))) + (dolist (item *rdfs-types*) + (when (get-ns-attribute property item :ns-uri *rdfs-ns*) + (error "~ardfs:~a is a type and not allowed here!" + err-pref item)))) + t) -(defun get-literals-of-node (node) - "Returns alist of attributes that are treated as literal nodes." - (let ((attributes nil)) - (dom:map-node-map - #'(lambda(attr) - (let ((attr-ns (dom:namespace-uri attr)) - (attr-name (get-node-name attr))) - (cond - ((string= attr-ns *rdf-ns*) - (unless (or (string= attr-name "ID") - (string= attr-name "about") - (string= attr-name "nodeID") - (string= attr-name "type")) - (push (list :type (concatenate-uri attr-ns attr-name) - :value (get-ns-attribute node attr-name)) - attributes))) - ((or (string= attr-ns *xml-ns*) - (string= attr-ns *xmlns-ns*)) - nil);;do nothing, all xml-attributes are no literals - ((string= attr-ns *rdfs-ns*) - (if (or (string= attr-name "subClassOf") - (string= attr-name "Class")) - (error "From get-literals-of-node(): rdfs:~a is not allowed here" - attr-name) - (push (list :type (concatenate-uri attr-ns attr-name) - :value (get-ns-attribute node attr-name - :ns-uri attr-ns)) - attributes))) - (t - (push (list :type (concatenate-uri attr-ns attr-name) - :value (get-ns-attribute node attr-name - :ns-uri attr-ns)) - attributes))))) - (dom:attributes node)) - attributes)) \ No newline at end of file Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Wed Jul 29 10:53:52 2009 @@ -28,7 +28,8 @@ :get-xml-base :absolutize-value :concatenate-uri - :push-string)) + :push-string + :node-to-string)) (in-package :xml-tools) @@ -65,13 +66,24 @@ (concatenate 'string prep-ns separator value)))) -(defun absolutize-value(value base tm-id) - "Returns the passed value as an absolute uri computed +(defun absolutize-id (id xml-base tm-id) + "Returns the passed id as an absolute uri computed with the given base and tm-id." + (declare (string id tm-id)) + (let ((prep-id (if (and (> (length id) 0) + (eql (elt id 0) #\#)) + id + (concatenate 'string "#" (string-left-trim "/" id))))) + (absolutize-value prep-id xml-base tm-id))) + + +(defun absolutize-value(value xml-base tm-id) + "Returns the passed value as an absolute uri computed + with the given xml-base and tm-id." (declare (string value tm-id)) (unless (absolute-uri-p tm-id) (error "From absolutize-value(): you must provide a stable identifier (PSI-style) for this TM: ~a" tm-id)) - (when (> (count #\# value) 2) + (when (> (count #\# value) 1) (error "From absolutize-value(): value is allowed to have only one \"#\": ~a" value)) (if (absolute-uri-p value) value @@ -80,8 +92,8 @@ (string-left-trim "/" value) "")) (prep-base - (if (> (length base) 0) - (string-right-trim "/" base) + (if (> (length xml-base) 0) + (string-right-trim "/" xml-base) ""))) (let ((fragment (if (and (> (length prep-value) 0) @@ -323,4 +335,27 @@ (loop for child-node across (dom:child-nodes elem) unless (or (dom:text-node-p child-node) (dom:comment-p child-node)) - collect child-node)) \ No newline at end of file + collect child-node)) + + +(defun node-to-string (elem) + "Transforms the passed node element recursively to a string." + (if (dom:text-node-p elem) + (dom:node-value elem) + (let ((node-name (dom:node-name elem)) + (attributes (dom:attributes elem)) + (child-nodes (dom:child-nodes elem)) + (elem-string "")) + (push-string (concatenate 'string "<" node-name) elem-string) + (dom:map-node-map + #'(lambda(attr) + (let ((attr-name (dom:node-name attr)) + (attr-value (dom:node-value attr))) + (push-string (concatenate 'string " " attr-name "=\"" + attr-value "\"") + elem-string))) + attributes) + (push-string ">" elem-string) + (loop for child-node across child-nodes + do (push-string (node-to-string child-node) elem-string)) + (push-string (concatenate 'string "") elem-string)))) \ No newline at end of file From lgiessmann at common-lisp.net Thu Jul 30 12:26:36 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 30 Jul 2009 08:26:36 -0400 Subject: [isidorus-cvs] r98 - in trunk/src: unit_tests xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Thu Jul 30 08:26:23 2009 New Revision: 98 Log: added more helpers and unit test ot the rdf-importer Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/tools.lisp 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 Thu Jul 30 08:26:23 2009 @@ -26,19 +26,26 @@ xpath-select-location-path get-ns-attribute absolute-uri-p) - (:export :test-get-literals-of-node + (:export :rdf-importer-test + :test-get-literals-of-node :test-parse-node - :run-rdf-importer-tests)) + :run-rdf-importer-tests + :test-get-literals-of-property + :test-parse-property + :test-get-types + :test-get-literals-of-content + :test-get-super-classes-of-node-content + :test-get-associations-of-node-content)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) (in-package :rdf-importer-test) -(def-suite importer-test +(def-suite rdf-importer-test :description "tests various key functions of the importer") -(in-suite importer-test) +(in-suite rdf-importer-test) (test test-get-literals-of-node @@ -351,7 +358,6 @@ "" "" "" - "" "" "" @@ -361,7 +367,6 @@ "" "" "" - "" "" "" @@ -390,57 +395,54 @@ 0) "UUID" :ns-uri *rdf2tm-ns*))) (is (= (length types) 10)) - (is-true (find-if #'(lambda(x) - (and - (string= (getf x :value) - (concatenate - 'string *rdf-ns* "anyType")) - (not (getf x :ID)))) - types)) - (is-true (find-if #'(lambda(x) - (and - (string= (getf x :value) - (concatenate - 'string tm-id - "/xml-base/first/attr-type")) - (not (getf x :ID)))) - types)) - (is-true (find-if #'(lambda(x) - (and (string= - (getf x :value) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) + (concatenate + 'string *rdf-ns* "anyType")) + (not (getf x :ID)))) + types)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) (concatenate 'string tm-id - "/xml-base/first/content-type-1")) - (string= (getf x :ID) - "rdfID"))) - types)) - (is-true (find-if #'(lambda(x) - (and (string= - (getf x :value) + "/xml-base/first/attr-type")) + (not (getf x :ID)))) + types)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) + "http://test-tm/xml-base/first/content-type-1") + (string= (getf x :ID) + "http://test-tm/xml-base/first#rdfID"))) + types)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) (concatenate 'string tm-id "/xml-base/first/c-about-type-2")) - (string= (getf x :ID) - "rdfID2"))) - types)) - (is-true (find-if #'(lambda(x) - (and - (string= (getf x :value) - "c-nodeID-type-2") - (not (getf x :ID)))) - types)) - (is-true (find-if #'(lambda(x) - (and - (string= (getf x :value) - "http://new-base#c-ID-type-2") - (not (getf x :ID)))) - types)) - (is-true (find-if #'(lambda(x) - (and - (string= (getf x :value) node-uuid) - (string= (getf x :ID) - "rdfID3"))) - types)) + (string= (getf x :ID) + "http://test-tm/xml-base/first#rdfID2"))) + types)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) "c-nodeID-type-2") + (not (getf x :ID)))) + types)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) + "http://new-base#c-ID-type-2") + (not (getf x :ID)))) + types)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :value) node-uuid) + (string= (getf x :ID) + "http://test-tm/xml-base/first#rdfID3"))) + types)) (is-true (= 10 (count-if #'(lambda(x) (> (length (getf x :value)) 0)) types)))))))) @@ -534,7 +536,8 @@ "childText5 ") (string= (getf x :type) "http://isidorus/props/lit5") - (string= (getf x :ID) "rdfID") + (string= (getf x :ID) + "http://test-tm/base/first#rdfID") (string= (getf x :lang) "de") (string= (getf x :datatype) *xml-string*))) literals)) @@ -549,10 +552,234 @@ literals))))))) +(test test-get-super-classes-of-node-content + (let ((doc-1 + (concatenate 'string "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)))) + (let ((node (elt (dom:child-nodes dom-1) 0)) + (tm-id "http://test-tm") + (xml-base "/base/initial")) + (is-true node) + (is-true (rdf-importer::parse-node node)) + (loop for property across (rdf-importer::child-nodes-or-text node) + do (is-true (rdf-importer::parse-property property))) + (let ((super-classes (rdf-importer::get-super-classes-of-node-content + node tm-id xml-base))) + (is (= (length super-classes) 8)) + (is-true (find-if + #'(lambda(x) + (string= (getf x :ID) + "http://test-tm/base/initial/xml-base/first#rdfID")) + super-classes)) + (is-true (map 'list + #'(lambda(x) + (and + (> (length (getf x :value)) 0) + (string= + (getf x :ID) + (concatenate 'string tm-id xml-base + "/xml-base/first/c-about-type-2")))) + super-classes)) + (is-true (map 'list + #'(lambda(x) + (and (string= (getf x :value) "c-nodeID-type-2") + (not (getf x :ID)))) + super-classes)) + (is-true (map 'list + #'(lambda(x) + (and (string= (getf x :value) + "http://new/base#c-ID-type-2") + (not (getf x :ID)))) + super-classes)) + (is (= (count-if #'(lambda(x) (> (length (getf x :value)) 0)) + super-classes) + 8)) + (is-true (find-if #'(lambda(x) + (string= (getf x :ID) + "http://test-tm/base/initial/xml-base/first#rdfID3")) + super-classes)) + (dom:append-child (elt (rdf-importer::child-nodes-or-text node) 1) + (dom:create-text-node dom-1 "new text")) + (signals error (rdf-importer::parse-property + (elt (rdf-importer::child-nodes-or-text node) 1)))))))) + + +(test test-get-associations-of-node-content + (let ((doc-1 + (concatenate 'string "" + "" + " " + "" + " " + "" + "" + " " + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + " " + "" + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) + (tm-id "http://test-tm")) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)) 1)) + (let ((node (elt (dom:child-nodes dom-1) 0))) + (loop for property across (rdf-importer::child-nodes-or-text node) + do (is-true (rdf-importer::parse-property property))) + (let ((associations + (rdf-importer::get-associations-of-node-content node tm-id nil))) + (is (= (length associations) 12)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) + (concatenate 'string *rdf-ns* "unknown")) + (string= (getf x :value) + "http://xml-base/first/assoc-1") + (not (getf x :ID)))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc1") + (string= (getf x :ID) "http://xml-base/first#rdfID-1") + (string= (getf x :value) "arc1-nodeID"))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc2") + (> (length (getf x :value)) 0) + (not (getf x :ID)))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc3") + (string= (getf x :ID) + "http://xml-base/first#rdfID-2") + (> (length (getf x :value)) 0))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc4") + (not (getf x :ID)) + (> (length (getf x :value)) 0))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc4") + (not (getf x :ID)) + (> (length (getf x :value)) 0))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc6") + (string= (getf x :ID) + "http://xml-base/first#rdfID-3") + (string= (getf x :value) + "http://xml-base/first/con-1"))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc7") + (not (getf x :ID)) + (string= (getf x :value) "con-2"))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc8") + (not (getf x :ID)) + (string= (getf x :value) + "http://xml-base/first#rdfID-4"))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) "http://test/arcs/arc9") + (string= (getf x :ID) + "http://xml-base/first/add#rdfID-5") + (> (length (getf x :value))))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) + (concatenate 'string *rdfs-ns* "type")) + (not (getf x :ID)) + (string= (getf x :value) + "http://xml-base/first/assoc-11"))) + associations)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :type) + (concatenate 'string *rdf-ns* + "subClassOf")) + (not (getf x :ID)) + (string= (getf x :value) "assoc-12"))) + associations))))))) + + (defun run-rdf-importer-tests() (it.bese.fiveam:run! 'test-get-literals-of-node) (it.bese.fiveam:run! 'test-parse-node) (it.bese.fiveam:run! 'test-get-literals-of-property) (it.bese.fiveam:run! 'test-parse-property) (it.bese.fiveam:run! 'test-get-types) - (it.bese.fiveam:run! 'test-get-literals-of-content)) \ No newline at end of file + (it.bese.fiveam:run! 'test-get-literals-of-content) + (it.bese.fiveam:run! 'test-get-super-classes-of-node-content) + (it.bese.fiveam:run! 'test-get-associations-of-node-content)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Thu Jul 30 08:26:23 2009 @@ -45,9 +45,10 @@ (if (and (string= elem-ns *rdf-ns*) (string= elem-name "RDF")) (let ((children (child-nodes-or-text rdf-dom))) - (loop for child across children - do (import-node child tm-id :document-id document-id - :xml-base xml-base :xml-lang xml-lang))) + (when children + (loop for child across children + do (import-node child tm-id :document-id document-id + :xml-base xml-base :xml-lang xml-lang)))) (import-node rdf-dom tm-id :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) @@ -58,24 +59,23 @@ (tm-id-p tm-id "import-node") (parse-node elem) (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) - (loop for property across (child-nodes-or-text elem) - do (parse-property property)) - (let ((about - (if (get-ns-attribute elem "about") - (absolutize-value (get-ns-attribute elem "about") - fn-xml-base tm-id) - nil)) + (when (child-nodes-or-text elem) + (loop for property across (child-nodes-or-text elem) + do (parse-property property))) + (let ((about (get-absolute-attribute elem tm-id xml-base "about")) (nodeID (get-ns-attribute elem "nodeID")) - (ID (get-ns-attribute elem "ID")) + (ID (get-absolute-attribute elem tm-id xml-base "ID")) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) (literals (append (get-literals-of-node elem xml-lang) (get-literals-of-node-content elem tm-id xml-base xml-lang))) - (associations nil) + (associations (get-associations-of-node-content elem tm-id xml-base)) (types (append (list (list :value (get-type-of-node-name elem) :ID nil)) (get-types-of-node-content elem tm-id fn-xml-base))) - (super-classes nil)) ;TODO: implement + (super-classes (get-super-classes-of-node-content elem tm-id xml-base))) + ;TODO: create elephant-objects + ;TODO: recursion on all nodes/arcs (declare (ignorable about nodeID ID UUID literals associations ;TODO: remove types super-classes))))) @@ -88,14 +88,9 @@ (fn-xml-base (get-xml-base node :old-base xml-base)) (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) (let ((literals - (loop for property across properties - when (let ((prp-xml-base (get-xml-base property - :old-base fn-xml-base))) - (let ((datatype - (when (get-ns-attribute property "datatype") - (absolutize-value - (get-ns-attribute property "datatype") - prp-xml-base tm-id))) + (when properties + (loop for property across properties + when (let ((datatype (get-ns-attribute property "datatype")) (parseType (get-ns-attribute property "parseType")) (nodeID (get-ns-attribute property "nodeID")) (resource (get-ns-attribute property "resource")) @@ -103,41 +98,33 @@ :ns-uri *rdf2tm-ns*))) (or (or datatype (string= parseType "Literal")) - (not (or nodeID resource UUID parseType))))) - collect (let ((content (child-nodes-or-text property)) - (prp-xml-base (get-xml-base property - :old-base fn-xml-base)) - (ID (get-ns-attribute property "ID")) - (prp-name (get-node-name property)) - (prp-ns (dom:namespace-uri property)) - (child-xml-lang - (get-xml-lang property :old-lang fn-xml-lang))) - (let ((full-name (concatenate-uri prp-ns prp-name)) - (datatype - (if (get-ns-attribute property "datatype") - (absolutize-value - (get-ns-attribute property "datatype") - prp-xml-base tm-id) - *xml-string*)) - (text - (cond - ((= (length content) 0) - "") - ((not (stringp content)) ;must be an element - (let ((text-val "")) - (loop for content-node across - (dom:child-nodes property) - do (push-string - (node-to-string content-node) - text-val)) - text-val)) - (t content)))) - (list :type full-name - :value text - :ID ID - :lang child-xml-lang - :datatype datatype)))))) - + (not (or nodeID resource UUID parseType)))) + collect (let ((content (child-nodes-or-text property)) + (ID (get-absolute-attribute property tm-id + fn-xml-base "ID")) + (child-xml-lang + (get-xml-lang property :old-lang fn-xml-lang))) + (let ((full-name (get-type-of-node-name property)) + (datatype (get-datatype property tm-id fn-xml-base)) + (text + (cond + ((= (length content) 0) + "") + ((not (stringp content)) ;must be an element + (let ((text-val "")) + (when (dom:child-nodes property) + (loop for content-node across + (dom:child-nodes property) + do (push-string + (node-to-string content-node) + text-val))) + text-val)) + (t content)))) + (list :type full-name + :value text + :ID ID + :lang child-xml-lang + :datatype datatype))))))) literals))) @@ -151,6 +138,7 @@ (defun get-types-of-node-content (node tm-id xml-base) "Returns a list of type-uris that corresponds to the node's content or attributes." + (tm-id-p tm-id "get-types-of-node-content") (let ((fn-xml-base (get-xml-base node :old-base xml-base))) (let ((attr-type (if (get-ns-attribute node "type") @@ -160,27 +148,27 @@ :ID nil)) nil)) (content-types - (loop for child across (child-nodes-or-text node) - when (and (string= (dom:namespace-uri child) *rdf-ns*) - (string= (get-node-name child) "type")) - collect (let ((nodeID (get-ns-attribute child "nodeID")) - (resource (if (get-ns-attribute child "resource") - (absolutize-value - (get-ns-attribute child "resource") - fn-xml-base tm-id))) - (UUID (get-ns-attribute child "UUID" - :ns-uri *rdf2tm-ns*)) - (ID (get-ns-attribute child "ID"))) - (if (or nodeID resource UUID) - (list :value (or nodeID resource UUID) - :ID ID) - (let ((child-xml-base - (get-xml-base child :old-base fn-xml-base))) - (loop for ref in - (get-node-refs (child-nodes-or-text child) - tm-id child-xml-base) - append (list :value ref - :ID ID)))))))) + (when (child-nodes-or-text node) + (loop for child across (child-nodes-or-text node) + when (and (string= (dom:namespace-uri child) *rdf-ns*) + (string= (get-node-name child) "type")) + collect (let ((nodeID (get-ns-attribute child "nodeID")) + (resource (get-absolute-attribute + child tm-id fn-xml-base "resource")) + (UUID (get-ns-attribute child "UUID" + :ns-uri *rdf2tm-ns*)) + (ID (get-absolute-attribute child tm-id + fn-xml-base "ID"))) + (if (or nodeID resource UUID) + (list :value (or nodeID resource UUID) + :ID ID) + (let ((child-xml-base + (get-xml-base child :old-base fn-xml-base))) + (loop for ref in + (get-node-refs (child-nodes-or-text child) + tm-id child-xml-base) + append (list :value ref + :ID ID))))))))) (remove-if #'null (append attr-type content-types))))) @@ -192,7 +180,7 @@ #'(lambda(attr) (let ((attr-ns (dom:namespace-uri attr)) (attr-name (get-node-name attr))) - (let ((l-type (concatenate-uri attr-ns attr-name)) + (let ((l-type (get-type-of-node-name attr)) (l-value (if (get-ns-attribute property attr-name :ns-uri attr-ns) (get-ns-attribute property attr-name @@ -236,7 +224,7 @@ #'(lambda(attr) (let ((attr-ns (dom:namespace-uri attr)) (attr-name (get-node-name attr))) - (let ((l-type (concatenate-uri attr-ns attr-name)) + (let ((l-type (get-type-of-node-name attr)) (l-value (if (get-ns-attribute node attr-name :ns-uri attr-ns) (get-ns-attribute node attr-name :ns-uri attr-ns) ""))) @@ -268,3 +256,86 @@ attributes)) +(defun get-super-classes-of-node-content (node tm-id xml-base) + "Returns a list of super-classes and IDs." + (declare (dom:element node)) + (tm-id-p tm-id "get-super-classes-of-node-content") + (let ((content (child-nodes-or-text node)) + (fn-xml-base (get-xml-base node :old-base xml-base))) + (when content + (loop for property across content + when (let ((prop-name (get-node-name property)) + (prop-ns (dom:namespace-uri property))) + (and (string= prop-name "subClassOf") + (string= prop-ns *rdfs-ns*))) + collect (let ((prop-xml-base (get-xml-base property + :old-base fn-xml-base))) + (let ((ID (get-absolute-attribute property tm-id + fn-xml-base "ID")) + (nodeID (get-ns-attribute property "nodeID")) + (resource + (get-absolute-attribute property tm-id + fn-xml-base "resource")) + (UUID (get-ns-attribute property "UUID" + :ns-uri *rdf2tm-ns*))) + (let ((value + (if (or nodeID resource UUID) + (or nodeID resource UUID) + (let ((res-values + (get-node-refs + (child-nodes-or-text property) + tm-id prop-xml-base))) + (first res-values))))) + (list :value value + :ID ID)))))))) + + +(defun get-associations-of-node-content (node tm-id xml-base) + "Returns a list of associations with a type, value and ID member." + (declare (dom:element node)) + (let ((properties (child-nodes-or-text node)) + (fn-xml-base (get-xml-base node :old-base xml-base))) + (loop for property across properties + when (let ((prop-name (get-node-name property)) + (prop-ns (dom:namespace-uri property)) + (prop-content (child-nodes-or-text property)) + (resource (get-absolute-attribute property tm-id + fn-xml-base "resource")) + (nodeID (get-ns-attribute property "nodeID")) + (type (get-ns-attribute property "type")) + (parseType (get-ns-attribute property "parseType")) + (UUID (get-ns-attribute property "UUID" + :ns-uri *rdf2tm-ns*))) + (and (or resource nodeID type UUID + (and parseType + (or (string= parseType "Collection") + (string= parseType "Resource"))) + (and (> (length prop-content) 0) + (not (stringp prop-content))) + (> (length (get-literals-of-property property nil)) 0)) + (not (and (string= prop-name "type") + (string= prop-ns *rdf-ns*))) + (not (and (string= prop-name "subClassOf") + (string= prop-ns *rdfs-ns*))))) + collect (let ((prop-xml-base (get-xml-base property + :old-base fn-xml-base))) + (let ((resource + (get-absolute-attribute property tm-id + fn-xml-base "resource")) + (nodeID (get-ns-attribute property "nodeID")) + (UUID (get-ns-attribute property "UUID" + :ns-uri *rdf2tm-ns*)) + (ID (get-absolute-attribute property tm-id + fn-xml-base "ID")) + (full-name (get-type-of-node-name property))) + (let ((value + (if (or nodeID resource UUID) + (or nodeID resource UUID) + (let ((res-values + (get-node-refs + (child-nodes-or-text property) + tm-id prop-xml-base))) + (first res-values))))) + (list :type full-name + :value value + :ID ID))))))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Thu Jul 30 08:26:23 2009 @@ -185,7 +185,7 @@ (error "~ardf:RDF not allowed here!" err-pref)) (unless (find property-name *rdf-properties* :test #'string=) - (format t "~aWarning: ~a is not a known RDF property!~%" + (format t "~aWarning: rdf:~a is not a known RDF property!~%" err-pref property-name))) (when (string= property-ns *rdfs-ns*) (when (find property-name *rdfs-types* :test #'string=) @@ -212,6 +212,7 @@ (subClassOf (get-ns-attribute property "subClassOf" :ns-uri *rdfs-ns*)) (literals (get-literals-of-property property nil)) (content (child-nodes-or-text property :trim t))) + (parse-property-name property) (when (and parseType (or nodeID resource datatype type literals)) (error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!" @@ -264,7 +265,8 @@ content)) (when (and (or type (and (string= node-name "type") - (string= node-ns *rdf-ns*))) + (string= node-ns *rdf-ns*)) + (> (length literals) 0)) (not (or nodeID resource)) (not content)) (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))) @@ -274,6 +276,21 @@ (if about (concatenate 'string "rdf:about (" about ")") (concatenate 'string "rdfs:subClassOf (" subClassOf ")")))) + (when (and (string= node-name "subClassOf") + (string= node-ns *rdfs-ns*) + (not (or nodeID resource content))) + (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))) + (when (and (or (and (string= node-name "type") + (string= node-ns *rdf-ns*)) + (and (string= node-name "subClassOf") + (string= node-ns *rdfs-ns*))) + (and (> (length content) 0) + (stringp content))) + (error "~awhen ~a not allowed to own literal content: ~a!" + err-pref (if (string= node-name "type") + "rdf:type" + "rdfs:subClassOf") + content)) (dolist (item *rdf-types*) (when (get-ns-attribute property item) (error "~ardf:~a is a type and not allowed here!" @@ -284,3 +301,28 @@ err-pref item)))) t) + +(defun get-absolute-attribute (elem tm-id xml-base attr-name + &key (ns-uri *rdf-ns*)) + "Returns an absolute 'attribute' or nil." + (declare (dom:element elem)) + (declare (string attr-name)) + (tm-id-p tm-id "get-ID") + (let ((attr (get-ns-attribute elem attr-name :ns-uri ns-uri)) + (fn-xml-base (get-xml-base elem :old-base xml-base))) + (when attr + (if (and (string= ns-uri *rdf-ns*) + (string= attr-name "ID")) + (absolutize-id attr fn-xml-base tm-id) + (absolutize-value attr fn-xml-base tm-id))))) + + +(defun get-datatype (elem tm-id xml-base) + "Returns a datatype value. The default is xml:string." + (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) + (let ((datatype + (get-absolute-attribute elem tm-id fn-xml-base "datatype"))) + (if datatype + datatype + *xml-string*)))) + \ No newline at end of file Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Thu Jul 30 08:26:23 2009 @@ -27,6 +27,7 @@ :get-xml-lang :get-xml-base :absolutize-value + :absolutize-id :concatenate-uri :push-string :node-to-string)) From lgiessmann at common-lisp.net Thu Jul 30 14:25:24 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 30 Jul 2009 10:25:24 -0400 Subject: [isidorus-cvs] r99 - in trunk/src: unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Thu Jul 30 10:25:23 2009 New Revision: 99 Log: added rdf:li handling for to rdf-importer Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp 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 Thu Jul 30 10:25:23 2009 @@ -35,7 +35,8 @@ :test-get-types :test-get-literals-of-content :test-get-super-classes-of-node-content - :test-get-associations-of-node-content)) + :test-get-associations-of-node-content + :test-parse-properties-of-node)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -258,7 +259,7 @@ (text-node (dom:create-text-node dom-1 "new text node"))) (is (= (length children) 19)) (loop for property across children - do (is-true (rdf-importer::parse-property property))) + do (is-true (rdf-importer::parse-property property 0))) (dotimes (i (length children)) (if (or (= i 0) (= i 1) (= i 3) (= i 4) (= i 9) (= i 17)) (is-true (get-ns-attribute (elt children i) "UUID" @@ -267,70 +268,70 @@ :ns-uri *rdf2tm-ns*)))) (let ((prop (elt children 0))) (dom:set-attribute-ns prop *rdf-ns* "parseType" "Unknown") - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "parseType" "Resource") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "ID" "newID") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "bad" "bad") - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-attribute-ns prop *rdf-ns* "bad") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:append-child prop text-node) - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-child prop text-node) - (is-true (rdf-importer::parse-property prop))) + (is-true (rdf-importer::parse-property prop 0))) (let ((prop (elt children 1))) (dom:set-attribute-ns prop *rdf-ns* "nodeID" "bad") - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-attribute-ns prop *rdf-ns* "nodeID") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "ID" "newID") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:append-child prop text-node) - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-child prop text-node) - (is-true (rdf-importer::parse-property prop))) + (is-true (rdf-importer::parse-property prop 0))) (let ((prop (elt children 3))) (dom:append-child prop text-node) - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-child prop text-node) - (is-true (rdf-importer::parse-property prop))) + (is-true (rdf-importer::parse-property prop 0))) (let ((prop (elt children 4))) (dom:append-child prop text-node) - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-child prop text-node) - (is-true (rdf-importer::parse-property prop))) + (is-true (rdf-importer::parse-property prop 0))) (let ((prop (elt children 5))) (dom:set-attribute-ns prop *rdf-ns* "type" "newType") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "unknown" "unknown") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:append-child prop text-node) - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-child prop text-node) - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:remove-attribute-ns prop *rdf-ns* "unknown") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:append-child prop text-node) - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-child prop text-node) - (is-true (rdf-importer::parse-property prop))) + (is-true (rdf-importer::parse-property prop 0))) (let ((prop (elt children 10))) (dom:set-attribute-ns prop *rdf-ns* "type" "newType") - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-attribute-ns prop *rdf-ns* "type") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "nodeID" "newNodeID") - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-attribute-ns prop *rdf-ns* "nodeID") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "resource" "newResource") - (signals error (rdf-importer::parse-property prop)) + (signals error (rdf-importer::parse-property prop 0)) (dom:remove-attribute-ns prop *rdf-ns* "resource") - (is-true (rdf-importer::parse-property prop)) + (is-true (rdf-importer::parse-property prop 0)) (dom:set-attribute-ns prop *rdf-ns* "ID" "newID") - (is-true (rdf-importer::parse-property prop)))))))) + (is-true (rdf-importer::parse-property prop 0)))))))) (test test-get-types @@ -382,7 +383,7 @@ (is-false (absolute-uri-p nil)) (let ((node (elt (dom:child-nodes dom-1) 0))) (loop for property across (rdf-importer::child-nodes-or-text node) - do (rdf-importer::parse-property property)) + do (rdf-importer::parse-property property 0)) (let ((types (append (list (list @@ -477,7 +478,7 @@ (let ((node (elt (dom:child-nodes dom-1) 0))) (dotimes (iter (length (dom:child-nodes node))) (is-true (rdf-importer::parse-property - (elt (dom:child-nodes node) iter)))) + (elt (dom:child-nodes node) iter) 0))) (let ((literals (rdf-importer::get-literals-of-node-content node tm-id nil nil))) (is (= (length literals) 7)) @@ -598,7 +599,7 @@ (is-true node) (is-true (rdf-importer::parse-node node)) (loop for property across (rdf-importer::child-nodes-or-text node) - do (is-true (rdf-importer::parse-property property))) + do (is-true (rdf-importer::parse-property property 0))) (let ((super-classes (rdf-importer::get-super-classes-of-node-content node tm-id xml-base))) (is (= (length super-classes) 8)) @@ -637,7 +638,7 @@ (dom:append-child (elt (rdf-importer::child-nodes-or-text node) 1) (dom:create-text-node dom-1 "new text")) (signals error (rdf-importer::parse-property - (elt (rdf-importer::child-nodes-or-text node) 1)))))))) + (elt (rdf-importer::child-nodes-or-text node) 1) 0))))))) (test test-get-associations-of-node-content @@ -685,7 +686,7 @@ (is (= (length (dom:child-nodes dom-1)) 1)) (let ((node (elt (dom:child-nodes dom-1) 0))) (loop for property across (rdf-importer::child-nodes-or-text node) - do (is-true (rdf-importer::parse-property property))) + do (is-true (rdf-importer::parse-property property 0))) (let ((associations (rdf-importer::get-associations-of-node-content node tm-id nil))) (is (= (length associations) 12)) @@ -774,6 +775,44 @@ associations))))))) +(test test-parse-properties-of-node + (let ((doc-1 + (concatenate 'string "" + "" + " " + "" + " " + "" + "" + " " + "" + "" + "" + "" + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)))) + (let ((node (elt (dom:child-nodes dom-1) 0))) + (is-true (rdf-importer::parse-properties-of-node node)) + (is (= (length rdf-importer::*_n-map*) 7)) + (format t "~a~%" rdf-importer::*_n-map*) + (dotimes (iter (length rdf-importer::*_n-map*)) + (is-true (find-if + #'(lambda(x) + (string= (getf x :type) + (concatenate + 'string *rdf-ns* "_" + (write-to-string (+ 1 iter))))) + rdf-importer::*_n-map*))) + (rdf-importer::remove-node-properties-from-*_n-map* node) + (is (= (length rdf-importer::*_n-map*) 0)))))) + + + (defun run-rdf-importer-tests() (it.bese.fiveam:run! 'test-get-literals-of-node) (it.bese.fiveam:run! 'test-parse-node) @@ -782,4 +821,5 @@ (it.bese.fiveam:run! 'test-get-types) (it.bese.fiveam:run! 'test-get-literals-of-content) (it.bese.fiveam:run! 'test-get-super-classes-of-node-content) - (it.bese.fiveam:run! 'test-get-associations-of-node-content)) \ No newline at end of file + (it.bese.fiveam:run! 'test-get-associations-of-node-content) + (it.bese.fiveam:run! 'test-parse-properties-of-node)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Thu Jul 30 10:25:23 2009 @@ -21,7 +21,8 @@ (defun rdf-importer (rdf-xml-path repository-path &key (tm-id nil) - (document-id (get-uuid))) + (document-id (get-uuid)) + (revision (get-revision))) (setf *document-id* document-id) (tm-id-p tm-id "rdf-importer") (let ((rdf-dom @@ -31,11 +32,11 @@ (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) - (import-dom rdf-dom :tm-id tm-id :document-id document-id))) + (import-dom rdf-dom revision :tm-id tm-id :document-id document-id)) + (setf *_n-map* nil)) - -(defun import-dom (rdf-dom &key (tm-id nil) (document-id *document-id*)) +(defun import-dom (rdf-dom revision &key (tm-id nil) (document-id *document-id*)) (tm-id-p tm-id "import-dom") (let ((xml-base (get-xml-base rdf-dom)) (xml-lang (get-xml-lang rdf-dom)) @@ -47,21 +48,18 @@ (let ((children (child-nodes-or-text rdf-dom))) (when children (loop for child across children - do (import-node child tm-id :document-id document-id + do (import-node child tm-id revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id :document-id document-id + (import-node rdf-dom tm-id revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) -(defun import-node (elem tm-id &key (document-id *document-id*) +(defun import-node (elem tm-id revision &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) - (declare (ignorable document-id)) ;TODO: remove (tm-id-p tm-id "import-node") (parse-node elem) (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) - (when (child-nodes-or-text elem) - (loop for property across (child-nodes-or-text elem) - do (parse-property property))) + (parse-properties-of-node elem) (let ((about (get-absolute-attribute elem tm-id xml-base "about")) (nodeID (get-ns-attribute elem "nodeID")) (ID (get-absolute-attribute elem tm-id xml-base "ID")) @@ -74,10 +72,27 @@ (list :value (get-type-of-node-name elem) :ID nil)) (get-types-of-node-content elem tm-id fn-xml-base))) (super-classes (get-super-classes-of-node-content elem tm-id xml-base))) - ;TODO: create elephant-objects - ;TODO: recursion on all nodes/arcs - (declare (ignorable about nodeID ID UUID literals associations ;TODO: remove - types super-classes))))) + + ;TODO: + ;get-topic by topic id + ;make psis + ;if no ones exist create one with topic id + ;add psis + ;make nametype topic with topic id + ;make instance-of associations + ;make topictype topics with topic id + ;make super-sub-class assoications + ;make and add names + ;make occurrencetype topics with topic id + ;make and add occurrences + ;make referenced topic with topic id + ;make and add associations + + + ;TODO: start recursion ... + (remove-node-properties-from-*_n-map* elem) + (or tm-id document-id revision about nodeID ID UUID literals ;TODO: remove + associations types super-classes)))) (defun get-literals-of-node-content (node tm-id xml-base xml-lang) @@ -128,13 +143,6 @@ literals))) -(defun get-type-of-node-name (node) - "Returns the type of the node name (namespace + tagname)." - (let ((node-name (get-node-name node)) - (node-ns (dom:namespace-uri node))) - (concatenate-uri node-ns node-name))) - - (defun get-types-of-node-content (node tm-id xml-base) "Returns a list of type-uris that corresponds to the node's content or attributes." Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Thu Jul 30 10:25:23 2009 @@ -37,6 +37,8 @@ concatenate-uri push-string node-to-string) + (:import-from :datamodel + get-revision) (:import-from :xml-importer get-uuid get-store-spec) @@ -59,18 +61,71 @@ "range" "range" "label" "comment" "member" "seeAlso" "isDefinedBy")) -(defun _n-p (node-name) +(defvar *_n-map* nil) + + +(defun _n-p (node) "Returns t if the given value is of the form _[0-9]+" - (when (and node-name - (> (length node-name) 0) - (eql (elt node-name 0) #\_)) - (let ((rest - (subseq node-name 1 (length node-name)))) - (declare (string node-name)) - (handler-case (let ((int - (parse-integer rest))) - int) - (condition () nil))))) + (let ((node-name (get-node-name node))) + (when (and node-name + (> (length node-name) 0) + (eql (elt node-name 0) #\_)) + (let ((rest + (subseq node-name 1 (length node-name)))) + (declare (string node-name)) + (handler-case (let ((int + (parse-integer rest))) + int) + (condition () nil)))))) + + +(defun set-_n-name (property _n-counter) + "Returns a name of the form _[1-9][0-9]* and adds a tupple + of the form :elem :type<_[1-9][0-9]*> to the + list *_n-map*. + If the dom-elem is already contained in the list only the + _[1-9][0-9]* name is returned." + (let ((map-item (find-if #'(lambda(x) + (eql (getf x :elem) property)) + *_n-map*))) + (if map-item + (getf map-item :type) + (let ((new-type-name + (concatenate 'string *rdf-ns* "_" (write-to-string _n-counter)))) + (push (list :elem property + :type new-type-name) + *_n-map*) + new-type-name)))) + + +(defun unset-_n-name (property) + (setf *_n-map* (remove-if + #'(lambda(x) + (eql (getf x :elem) property)) + *_n-map*))) + + +(defun remove-node-properties-from-*_n-map* (node) + "Removes all node's properties from the list *_n-map*." + (declare (dom:element node)) + (let ((properties (child-nodes-or-text node))) + (when properties + (loop for property across properties + do (unset-_n-name property))))) + + +(defun get-type-of-node-name (node) + "Returns the type of the node name (namespace + tagname). + When the node is contained in *_n-map* the corresponding + value of this map will be returned." + (let ((map-item (find-if #'(lambda(x) + (eql (getf x :elem) node)) + *_n-map*))) + (if map-item + (getf map-item :type) + (let ((node-name (get-node-name node)) + (node-ns (dom:namespace-uri node))) + (concatenate-uri node-ns node-name))))) (defun parse-node-name (node) @@ -169,7 +224,7 @@ (or ID nodeID about UUID)))))) -(defun parse-property-name (property) +(defun parse-property-name (property _n-counter) "Parses the given property's name to the known rdf/rdfs nodes and arcs. If the given name es equal to an node an error is thrown otherwise there is displayed a warning when the rdf ord rdfs namespace is used." @@ -193,11 +248,14 @@ err-pref property-name)) (unless (find property-name *rdfs-properties* :test #'string=) (format t "~aWarning: rdfs:~a is not a known rdfs:type!~%" - err-pref property-name)))) + err-pref property-name))) + (when (and (string= property-ns *rdf-ns*) + (string= property-name "li")) + (set-_n-name property _n-counter))) t) -(defun parse-property (property) +(defun parse-property (property _n-counter) "Parses a property that represents a rdf-arc." (declare (dom:element property)) (let ((err-pref "From parse-property(): ") @@ -212,7 +270,7 @@ (subClassOf (get-ns-attribute property "subClassOf" :ns-uri *rdfs-ns*)) (literals (get-literals-of-property property nil)) (content (child-nodes-or-text property :trim t))) - (parse-property-name property) + (parse-property-name property _n-counter) (when (and parseType (or nodeID resource datatype type literals)) (error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!" @@ -302,6 +360,20 @@ t) +(defun parse-properties-of-node (node) + (let ((child-nodes (child-nodes-or-text node)) + (_n-counter 0)) + (when child-nodes + (loop for property across child-nodes + do (let ((prop-name (get-node-name property)) + (prop-ns (dom:namespace-uri node))) + (when (and (string= prop-name "li") + (string= prop-ns *rdf-ns*)) + (incf _n-counter)) + (parse-property property _n-counter))))) + t) + + (defun get-absolute-attribute (elem tm-id xml-base attr-name &key (ns-uri *rdf-ns*)) "Returns an absolute 'attribute' or nil." From lgiessmann at common-lisp.net Fri Jul 31 11:54:47 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 31 Jul 2009 07:54:47 -0400 Subject: [isidorus-cvs] r100 - in trunk/src: unit_tests xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Fri Jul 31 07:54:22 2009 New Revision: 100 Log: fixed some problems with rdf-helper functions; cimpleted the handling for rdf:li; fixed and added some unite test for the rdf-importer Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/tools.lisp 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 Fri Jul 31 07:54:22 2009 @@ -387,7 +387,8 @@ (let ((types (append (list (list - :value (rdf-importer::get-type-of-node-name node) + :topicid (rdf-importer::get-type-of-node-name node) + :psi (rdf-importer::get-type-of-node-name node) :ID nil)) (rdf-importer::get-types-of-node-content node tm-id nil))) (node-uuid (get-ns-attribute @@ -398,14 +399,21 @@ (is (= (length types) 10)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + (concatenate + 'string *rdf-ns* "anyType")) + (string= (getf x :topicid) (concatenate 'string *rdf-ns* "anyType")) (not (getf x :ID)))) types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + (concatenate + 'string tm-id + "/xml-base/first/attr-type")) + (string= (getf x :psi) (concatenate 'string tm-id "/xml-base/first/attr-type")) @@ -413,14 +421,20 @@ types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + "http://test-tm/xml-base/first/content-type-1") + (string= (getf x :psi) "http://test-tm/xml-base/first/content-type-1") (string= (getf x :ID) "http://test-tm/xml-base/first#rdfID"))) types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + (concatenate + 'string tm-id + "/xml-base/first/c-about-type-2")) + (string= (getf x :psi) (concatenate 'string tm-id "/xml-base/first/c-about-type-2")) @@ -429,23 +443,27 @@ types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) "c-nodeID-type-2") + (and (string= (getf x :topicid) "c-nodeID-type-2") + (not (getf x :psi)) (not (getf x :ID)))) types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + "http://new-base#c-ID-type-2") + (string= (getf x :psi) "http://new-base#c-ID-type-2") (not (getf x :ID)))) types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) node-uuid) + (and (string= (getf x :topicid) node-uuid) + (not (getf x :psi)) (string= (getf x :ID) "http://test-tm/xml-base/first#rdfID3"))) types)) (is-true (= 10 (count-if #'(lambda(x) - (> (length (getf x :value)) 0)) + (> (length (getf x :topicid)) 0)) types)))))))) @@ -603,38 +621,61 @@ (let ((super-classes (rdf-importer::get-super-classes-of-node-content node tm-id xml-base))) (is (= (length super-classes) 8)) - (is-true (find-if + (is-true + (find-if + #'(lambda(x) + (and + (string= + (getf x :psi) + "http://test-tm/base/initial/xml-base/first/content-type-1") + (string= + (getf x :topicid) + "http://test-tm/base/initial/xml-base/first/content-type-1") + (string= + (getf x :ID) + "http://test-tm/base/initial/xml-base/first#rdfID"))) + super-classes)) + (is-true (find-if + #'(lambda(x) + (and + (string= + (getf x :topicid) + (concatenate 'string tm-id xml-base + "/xml-base/first/c-about-type-2")) + (string= + (getf x :psi) + (concatenate 'string tm-id xml-base + "/xml-base/first/c-about-type-2")) + (string= (getf x :ID) + (concatenate 'string tm-id xml-base + "/xml-base/first#rdfID2")))) + super-classes)) + (is-true (find-if #'(lambda(x) - (string= (getf x :ID) - "http://test-tm/base/initial/xml-base/first#rdfID")) + (and (string= (getf x :topicid) "c-nodeID-type-2") + (not (getf x :psi)) + (not (getf x :ID)))) + super-classes)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :topicid) + "http://new-base#c-ID-type-2") + (string= (getf x :psi) + "http://new-base#c-ID-type-2") + (not (getf x :ID)))) super-classes)) - (is-true (map 'list - #'(lambda(x) - (and - (> (length (getf x :value)) 0) - (string= - (getf x :ID) - (concatenate 'string tm-id xml-base - "/xml-base/first/c-about-type-2")))) - super-classes)) - (is-true (map 'list - #'(lambda(x) - (and (string= (getf x :value) "c-nodeID-type-2") - (not (getf x :ID)))) - super-classes)) - (is-true (map 'list - #'(lambda(x) - (and (string= (getf x :value) - "http://new/base#c-ID-type-2") - (not (getf x :ID)))) - super-classes)) - (is (= (count-if #'(lambda(x) (> (length (getf x :value)) 0)) + (is (= (count-if #'(lambda(x) (> (length (getf x :topicid)) 0)) super-classes) 8)) - (is-true (find-if #'(lambda(x) - (string= (getf x :ID) - "http://test-tm/base/initial/xml-base/first#rdfID3")) - super-classes)) + (is-true (find-if + #'(lambda(x) + (and + (string= + (getf x :ID) + "http://test-tm/base/initial/xml-base/first#rdfID3") + (not (getf x :psi)) + (> (length (getf x :topicid))))) + super-classes)) (dom:append-child (elt (rdf-importer::child-nodes-or-text node) 1) (dom:create-text-node dom-1 "new text")) (signals error (rdf-importer::parse-property @@ -694,7 +735,9 @@ #'(lambda(x) (and (string= (getf x :type) (concatenate 'string *rdf-ns* "unknown")) - (string= (getf x :value) + (string= (getf x :topicid) + "http://xml-base/first/assoc-1") + (string= (getf x :psi) "http://xml-base/first/assoc-1") (not (getf x :ID)))) associations)) @@ -702,12 +745,14 @@ #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc1") (string= (getf x :ID) "http://xml-base/first#rdfID-1") - (string= (getf x :value) "arc1-nodeID"))) + (string= (getf x :topicid) "arc1-nodeID") + (not (getf x :psi)))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc2") - (> (length (getf x :value)) 0) + (> (length (getf x :topicid)) 0) + (not (getf x :psi)) (not (getf x :ID)))) associations)) (is-true (find-if @@ -715,39 +760,47 @@ (and (string= (getf x :type) "http://test/arcs/arc3") (string= (getf x :ID) "http://xml-base/first#rdfID-2") - (> (length (getf x :value)) 0))) + (not (getf x :psi)) + (> (length (getf x :topicid)) 0))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc4") (not (getf x :ID)) - (> (length (getf x :value)) 0))) + (not (getf x :psi)) + (> (length (getf x :topicid)) 0))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc4") (not (getf x :ID)) - (> (length (getf x :value)) 0))) + (not (getf x :psi)) + (> (length (getf x :topicid)) 0))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc6") (string= (getf x :ID) "http://xml-base/first#rdfID-3") - (string= (getf x :value) + (string= (getf x :topicid) + "http://xml-base/first/con-1") + (string= (getf x :psi) "http://xml-base/first/con-1"))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc7") (not (getf x :ID)) - (string= (getf x :value) "con-2"))) + (string= (getf x :topicid) "con-2") + (not (getf x :psi)))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc8") (not (getf x :ID)) - (string= (getf x :value) + (string= (getf x :topicid) + "http://xml-base/first#rdfID-4") + (string= (getf x :psi) "http://xml-base/first#rdfID-4"))) associations)) (is-true (find-if @@ -755,14 +808,17 @@ (and (string= (getf x :type) "http://test/arcs/arc9") (string= (getf x :ID) "http://xml-base/first/add#rdfID-5") - (> (length (getf x :value))))) + (not (getf x :psi)) + (> (length (getf x :topicid))))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) (concatenate 'string *rdfs-ns* "type")) (not (getf x :ID)) - (string= (getf x :value) + (string= (getf x :psi) + "http://xml-base/first/assoc-11") + (string= (getf x :topicid) "http://xml-base/first/assoc-11"))) associations)) (is-true (find-if @@ -771,7 +827,8 @@ (concatenate 'string *rdf-ns* "subClassOf")) (not (getf x :ID)) - (string= (getf x :value) "assoc-12"))) + (not (getf x :psi)) + (string= (getf x :topicid) "assoc-12"))) associations))))))) @@ -780,26 +837,30 @@ (concatenate 'string "" + "rdf:about=\"resource\" rdf:type=\"attr-type\" " + "rdf:li=\"li-attr\">" "" - " " + " text-1 " "" - " " + " " "" "" " " - "" - "" - "" - "" + " text-3" + "" + " text-4 " + "" + "text-5" ""))) - (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) + (tm-id "http://test-tm")) + (setf rdf-importer::*_n-map* nil) (is-true dom-1) (is (= (length (dom:child-nodes dom-1)))) (let ((node (elt (dom:child-nodes dom-1) 0))) + (is-true (rdf-importer::parse-node node)) (is-true (rdf-importer::parse-properties-of-node node)) - (is (= (length rdf-importer::*_n-map*) 7)) - (format t "~a~%" rdf-importer::*_n-map*) + (is (= (length rdf-importer::*_n-map*) 8)) (dotimes (iter (length rdf-importer::*_n-map*)) (is-true (find-if #'(lambda(x) @@ -808,8 +869,104 @@ 'string *rdf-ns* "_" (write-to-string (+ 1 iter))))) rdf-importer::*_n-map*))) + (let ((assocs + (rdf-importer::get-associations-of-node-content node tm-id nil)) + (content-literals + (rdf-importer::get-literals-of-node-content node tm-id nil "de")) + (attr-literals + (rdf-importer::get-literals-of-node node nil))) + (is (= (length assocs) 5)) + (is (= (length content-literals) 5)) + (is (= (length attr-literals) 1)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :type) + (concatenate 'string *rdf-ns* "_1")) + (not (getf x :lang)) + (string= (getf x :value) "li-attr") + (not (getf x :lang)) + (not (getf x :ID)))) + attr-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :topicid) + "http://xml-base/first/anyType") + (string= (getf x :psi) + "http://xml-base/first/anyType") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_2")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " text-1 ") + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_3")) + (not (getf x :ID)))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :topicid) "anyClass") + (not (getf x :psi)) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_4")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " ") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_5")) + (string= (getf x :datatype) *xml-string*) + (string= (getf x :lang) "de") + (not (getf x :ID)))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :topicid) + "http://xml-base/first/assoc-1") + (string= (getf x :psi) + "http://xml-base/first/assoc-1") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_6")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (> (length (getf x :topicid)) 0) + (not (getf x :psi)) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_7")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " text-3") + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_8")) + (not (getf x :ID)))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " text-4 ") + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*) + (string= + (getf x :type) + (concatenate 'string *rdf-ns* "arc6")) + (string= + (getf x :ID) + "http://xml-base/first#rdfID-3"))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) "text-5") + (string= (getf x :lang) nil) + (string= (getf x :datatype) *xml-string*) + (string= + (getf x :type) + (concatenate 'string *rdf-ns* "arcs")) + (string= + (getf x :ID) + "http://xml-base/first#rdfID-4"))) + content-literals))) (rdf-importer::remove-node-properties-from-*_n-map* node) (is (= (length rdf-importer::*_n-map*) 0)))))) + Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Fri Jul 31 07:54:22 2009 @@ -22,7 +22,7 @@ &key (tm-id nil) (document-id (get-uuid)) - (revision (get-revision))) + (start-revision (d:get-revision))) (setf *document-id* document-id) (tm-id-p tm-id "rdf-importer") (let ((rdf-dom @@ -32,11 +32,12 @@ (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) - (import-dom rdf-dom revision :tm-id tm-id :document-id document-id)) + (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) (setf *_n-map* nil)) -(defun import-dom (rdf-dom revision &key (tm-id nil) (document-id *document-id*)) +(defun import-dom (rdf-dom start-revision + &key (tm-id nil) (document-id *document-id*)) (tm-id-p tm-id "import-dom") (let ((xml-base (get-xml-base rdf-dom)) (xml-lang (get-xml-lang rdf-dom)) @@ -48,14 +49,15 @@ (let ((children (child-nodes-or-text rdf-dom))) (when children (loop for child across children - do (import-node child tm-id revision :document-id document-id + do (import-node child tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id revision :document-id document-id + (import-node rdf-dom tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) -(defun import-node (elem tm-id revision &key (document-id *document-id*) +(defun import-node (elem tm-id start-revision &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) + (remove-node-properties-from-*_n-map* elem) ;in case of an failed last call (tm-id-p tm-id "import-node") (parse-node elem) (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) @@ -69,20 +71,23 @@ xml-base xml-lang))) (associations (get-associations-of-node-content elem tm-id xml-base)) (types (append (list - (list :value (get-type-of-node-name elem) :ID nil)) + (list :topicid (get-type-of-node-name elem) + :psi (get-type-of-node-name elem) + :ID nil)) (get-types-of-node-content elem tm-id fn-xml-base))) (super-classes (get-super-classes-of-node-content elem tm-id xml-base))) - + (let ((topic-stub (make-topic-stub-from-node about ID nodeID UUID + start-revision + :document-id document-id))) + ;TODO: - ;get-topic by topic id - ;make psis - ;if no ones exist create one with topic id - ;add psis - ;make nametype topic with topic id + ;*get-topic by topic id + ;*make psis + ;*if the topic does not exist create one with topic id + ;*add psis ;make instance-of associations ;make topictype topics with topic id - ;make super-sub-class assoications - ;make and add names + ;make super-sub-class associations ;make occurrencetype topics with topic id ;make and add occurrences ;make referenced topic with topic id @@ -91,8 +96,46 @@ ;TODO: start recursion ... (remove-node-properties-from-*_n-map* elem) - (or tm-id document-id revision about nodeID ID UUID literals ;TODO: remove - associations types super-classes)))) + (or tm-id document-id topic-stub nodeID UUID literals ;TODO: remove + associations types super-classes))))) + + +(defun make-topic-stub-from-node (about ID nodeId UUID start-revision + &key (document-id *document-id*)) + "Returns a topic corresponding to the passed parameters. + When the searched topic does not exist there will be created one. + If about or ID is set there will aslo be created a new PSI." +; (let ((topic-id (or about ID nodeID UUID)) +; (psi-value (or about ID)) +; (err-pref "From make-topic-stub-from-node(): ")) +; (unless topic-id +; (error "~aone of about ID nodeID UUID must be set!" +; err-pref)) +; (elephant:ensure-transaction (:txn-nosync t) +; (let ((top (get-item-by-id topic-id :xtm-id document-id +; :revision start-revision))) +; (let ((topic-psis (map 'list #'d:uri (d:psis top)))) +; (if (and psi-value +; (not (find psi-value topic-psis :test #'string=))) +; (let ((psis (list (d::make-instance +; 'd:PersistentIdC +; :uri psi-value +; :start-revision start-revision)))) +; ;create only a new topic if there existed no one +; (d::make-instance 'd:TopicC +; :topicid topic-id +; :psis psis +; :xtm-id document-id +; :start-revision start-revision)) +; top)))))) +) + + +(defun make-occurrence-from-node (top literals start-revision + &key (document-id *document-id*)) +; (loop for literal in literals +; do (let ((type + ) (defun get-literals-of-node-content (node tm-id xml-base xml-lang) @@ -110,10 +153,14 @@ (nodeID (get-ns-attribute property "nodeID")) (resource (get-ns-attribute property "resource")) (UUID (get-ns-attribute property "UUID" - :ns-uri *rdf2tm-ns*))) - (or (or datatype - (string= parseType "Literal")) - (not (or nodeID resource UUID parseType)))) + :ns-uri *rdf2tm-ns*)) + (type (get-ns-attribute property "type")) + (prop-literals (get-literals-of-property + property nil))) + (and (or (or datatype + (string= parseType "Literal")) + (not (or nodeID resource UUID parseType))) + (not (or type prop-literals)))) collect (let ((content (child-nodes-or-text property)) (ID (get-absolute-attribute property tm-id fn-xml-base "ID")) @@ -151,8 +198,10 @@ (let ((attr-type (if (get-ns-attribute node "type") (list - (list :value (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + (list :topicid (absolutize-value (get-ns-attribute node "type") + fn-xml-base tm-id) + :psi (absolutize-value (get-ns-attribute node "type") + fn-xml-base tm-id) :ID nil)) nil)) (content-types @@ -168,15 +217,18 @@ (ID (get-absolute-attribute child tm-id fn-xml-base "ID"))) (if (or nodeID resource UUID) - (list :value (or nodeID resource UUID) + (list :topicid (or nodeID resource UUID) + :psi resource :ID ID) (let ((child-xml-base (get-xml-base child :old-base fn-xml-base))) - (loop for ref in - (get-node-refs (child-nodes-or-text child) - tm-id child-xml-base) - append (list :value ref - :ID ID))))))))) + (let ((refs + (get-node-refs + (child-nodes-or-text child) + tm-id child-xml-base))) + (list :topicid (getf (first refs) :topicid) + :psi (getf (first refs) :psi) + :ID ID))))))))) (remove-if #'null (append attr-type content-types))))) @@ -286,16 +338,16 @@ fn-xml-base "resource")) (UUID (get-ns-attribute property "UUID" :ns-uri *rdf2tm-ns*))) - (let ((value - (if (or nodeID resource UUID) - (or nodeID resource UUID) - (let ((res-values - (get-node-refs - (child-nodes-or-text property) - tm-id prop-xml-base))) - (first res-values))))) - (list :value value - :ID ID)))))))) + (if (or nodeID resource UUID) + (list :topicid (or nodeID resource UUID) + :psi resource + :ID ID) + (let ((refs (get-node-refs + (child-nodes-or-text property) + tm-id prop-xml-base))) + (list :topicid (getf (first refs) :topicid) + :psi (getf (first refs) :psi) + :ID ID))))))))) (defun get-associations-of-node-content (node tm-id xml-base) @@ -336,14 +388,15 @@ (ID (get-absolute-attribute property tm-id fn-xml-base "ID")) (full-name (get-type-of-node-name property))) - (let ((value - (if (or nodeID resource UUID) - (or nodeID resource UUID) - (let ((res-values - (get-node-refs - (child-nodes-or-text property) - tm-id prop-xml-base))) - (first res-values))))) - (list :type full-name - :value value - :ID ID))))))) \ No newline at end of file + (if (or nodeID resource UUID) + (list :type full-name + :topicid (or nodeID resource UUID) + :psi resource + :ID ID) + (let ((refs (get-node-refs + (child-nodes-or-text property) + tm-id prop-xml-base))) + (list :type full-name + :topicid (getf (first refs) :topicid) + :psi (getf (first refs) :psi) + :ID ID)))))))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Fri Jul 31 07:54:22 2009 @@ -7,7 +7,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :rdf-importer - (:use :cl :cxml :elephant :datamodel :isidorus-threading) + (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel) (:import-from :constants *rdf-ns* *rdfs-ns* @@ -37,8 +37,6 @@ concatenate-uri push-string node-to-string) - (:import-from :datamodel - get-revision) (:import-from :xml-importer get-uuid get-store-spec) @@ -52,7 +50,7 @@ "Statement" "Property" "XMLLiteral")) (defvar *rdf-properties* (list "type" "first" "rest" "subject" "predicate" - "object")) + "object" "li")) (defvar *rdfs-types* (list "Resource" "Literal" "Class" "Datatype" "Container" "ContainerMembershipProperty")) @@ -99,10 +97,10 @@ (defun unset-_n-name (property) - (setf *_n-map* (remove-if - #'(lambda(x) - (eql (getf x :elem) property)) - *_n-map*))) + "Deletes the passed property tupple of the *_n-map* list." + (setf *_n-map* (remove-if #'(lambda(x) + (eql (getf x :elem) property)) + *_n-map*))) (defun remove-node-properties-from-*_n-map* (node) @@ -111,7 +109,10 @@ (let ((properties (child-nodes-or-text node))) (when properties (loop for property across properties - do (unset-_n-name property))))) + do (unset-_n-name property)))) + (dom:map-node-map + #'(lambda(attr) (unset-_n-name attr)) + (dom:attributes node))) (defun get-type-of-node-name (node) @@ -221,7 +222,8 @@ (get-ns-attribute node "about") fn-xml-base tm-id))) (UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*))) - (or ID nodeID about UUID)))))) + (list :topicid (or ID about nodeID UUID) + :psi (or ID about))))))) (defun parse-property-name (property _n-counter) @@ -239,7 +241,8 @@ (when (string= property-name "RDF") (error "~ardf:RDF not allowed here!" err-pref)) - (unless (find property-name *rdf-properties* :test #'string=) + (unless (or (find property-name *rdf-properties* :test #'string=) + (_n-p property)) (format t "~aWarning: rdf:~a is not a known RDF property!~%" err-pref property-name))) (when (string= property-ns *rdfs-ns*) @@ -326,7 +329,7 @@ (string= node-ns *rdf-ns*)) (> (length literals) 0)) (not (or nodeID resource)) - (not content)) + (not content)) (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))) (when (or about subClassOf) (error "~a~a not allowed here!" @@ -361,8 +364,19 @@ (defun parse-properties-of-node (node) + "Parses all node's properties by calling the parse-propery + function and sets all rdf:li properties as a tupple to the + *_n-map* list." (let ((child-nodes (child-nodes-or-text node)) (_n-counter 0)) + (when (get-ns-attribute node "li") + (dom:map-node-map + #'(lambda(attr) + (when (and (string= (get-node-name attr) "li") + (string= (dom:namespace-uri attr) *rdf-ns*)) + (incf _n-counter) + (set-_n-name attr _n-counter))) + (dom:attributes node))) (when child-nodes (loop for property across child-nodes do (let ((prop-name (get-node-name property)) Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Fri Jul 31 07:54:22 2009 @@ -117,10 +117,17 @@ its value as a string." (declare (dom:element elem)) (let ((new-lang - (get-ns-attribute elem "lang" :ns-uri *xml-ns*))) + (let ((val + (get-ns-attribute elem "lang" :ns-uri *xml-ns*))) + (when val + (string-trim '(#\Space #\Tab #\Newline) val))))) (if (dom:has-attribute-ns elem *xml-ns* "lang") - new-lang - old-lang))) + (if (= (length new-lang) 0) + nil + new-lang) + (if (= (length old-lang) 0) + nil + old-lang)))) (defun get-xml-base(elem &key (old-base nil)) @@ -132,7 +139,9 @@ (if (find #\# (get-ns-attribute elem "base" :ns-uri *xml-ns*)) (error "From get-xml-base(): the base-uri ~a is not valid" (get-ns-attribute elem *xml-ns* "base")) - (get-ns-attribute elem "base" :ns-uri *xml-ns*)))) + (when (get-ns-attribute elem "base" :ns-uri *xml-ns*) + (string-trim '(#\Space #\Tab #\Newline) + (get-ns-attribute elem "base" :ns-uri *xml-ns*)))))) (if (and (> (length inner-base) 0) (eql (elt inner-base 0) #\/)) (subseq inner-base 1 (length inner-base)) From lgiessmann at common-lisp.net Fri Jul 31 22:41:07 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 31 Jul 2009 18:41:07 -0400 Subject: [isidorus-cvs] r101 - in trunk/src: . xml/rdf Message-ID: Author: lgiessmann Date: Fri Jul 31 18:41:02 2009 New Revision: 101 Log: added some functions to write the actual tm constructs into elephant; added a minimal core_psis.xtm to initialize the rdf-module Added: trunk/src/xml/rdf/rdf_core_psis.xtm Modified: trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/xml-constants.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Fri Jul 31 18:41:02 2009 @@ -1,3 +1,4 @@ + ;;+----------------------------------------------------------------------------- ;;+ Isidorus ;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann @@ -26,7 +27,13 @@ :*xml-ns* :*xmlns-ns* :*xml-string* - :*rdf2tm-ns*)) + :*rdf2tm-ns* + :*rdf-statement* + :*rdf-object* + :*rdf-subject* + :*rdf-predicate* + :*rdf2tm-object* + :*rdf2tm-subject*)) (in-package :constants) (defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/") @@ -63,4 +70,16 @@ (defparameter *xml-string* "http://www.w3.org/2001/XMLSchema#string") -(defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/") \ No newline at end of file +(defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping#") + +(defparameter *rdf-statement* "http://www.w3.org/1999/02/22-rdf-syntax-ns#Statement") + +(defparameter *rdf-object* "http://www.w3.org/1999/02/22-rdf-syntax-ns#object") + +(defparameter *rdf-subject* "http://www.w3.org/1999/02/22-rdf-syntax-ns#subject") + +(defparameter *rdf-predicate* "http://www.w3.org/1999/02/22-rdf-syntax-ns#predicate") + +(defparameter *rdf2tm-object* "http://isidorus/rdf2tm_mapping#object") + +(defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping#subject") \ No newline at end of file Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Fri Jul 31 18:41:02 2009 @@ -20,6 +20,7 @@ :components ( (:file "constants") (:static-file "xml/xtm/core_psis.xtm") + (:static-file "xml/rdf/rdf_core_psis.xtm") (:file "xml-constants" :depends-on ("xml/xtm/core_psis.xtm" "constants")) Modified: trunk/src/xml-constants.lisp ============================================================================== --- trunk/src/xml-constants.lisp (original) +++ trunk/src/xml-constants.lisp Fri Jul 31 18:41:02 2009 @@ -13,7 +13,8 @@ (:import-from :constants *isidorus-system*) (:export :*xml-component* - :*core_psis.xtm*)) + :*core_psis.xtm* + :*rdf_core_psis.xtm*)) (in-package :xml-constants) @@ -24,3 +25,6 @@ (asdf:component-pathname (asdf:find-component *isidorus-system* "xml/xtm/core_psis.xtm"))) +(defparameter *rdf_core_psis.xtm* + (asdf:component-pathname + (asdf:find-component *isidorus-system* "xml/rdf/rdf_core_psis.xtm"))) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Fri Jul 31 18:41:02 2009 @@ -11,11 +11,22 @@ (defvar *document-id* nil) -(defun tm-id-p (tm-id fun-name) - "Checks the validity of the passed tm-id." - (unless (absolute-uri-p tm-id) - (error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!" - fun-name tm-id))) +(defun setup-rdf-module (rdf-xml-path repository-path + &key tm-id (document-id (get-uuid))) + "Sets up the data base by importing core_psis.xtm and + rdf_core_psis.xtm afterwards the file corresponding + to the give file path is imported." + (declare ((or pathname string) rdf-xml-path)) + (declare ((or pathname string) repository-path)) + (unless elephant:*store-controller* + (elephant:open-store + (get-store-spec repository-path))) + (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))) (defun rdf-importer (rdf-xml-path repository-path @@ -23,27 +34,54 @@ (tm-id nil) (document-id (get-uuid)) (start-revision (d:get-revision))) + "Imports the file correponding to the given path." (setf *document-id* document-id) (tm-id-p tm-id "rdf-importer") + (unless elephant:*store-controller* + (elephant:open-store + (get-store-spec repository-path))) (let ((rdf-dom (dom:document-element (cxml:parse-file (truename rdf-xml-path) (cxml-dom:make-dom-builder))))) - (unless elephant:*store-controller* - (elephant:open-store - (get-store-spec repository-path))) (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) (setf *_n-map* nil)) +(defun init-rdf-module (&optional (revision (get-revision))) + "Imports the file rdf_core_psis.xtm. core_psis.xtm has to be imported + before." + (with-writer-lock + (with-tm (revision "rdf.xtm" "http://isidorus/rdf2tm_mapping/rdf.xtm") + (let + ((core-dom + (cxml:parse-file *rdf_core_psis.xtm* (cxml-dom:make-dom-builder)))) + (loop for top-elem across + (xpath-child-elems-by-qname (dom:document-element core-dom) + *xtm2.0-ns* "topic") + do + (let + ((top + (from-topic-elem-to-stub top-elem revision + :xtm-id *rdf-core-xtm*))) + (add-to-topicmap xml-importer::tm top))))))) + + +(defun tm-id-p (tm-id fun-name) + "Checks the validity of the passed tm-id." + (unless (absolute-uri-p tm-id) + (error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!" + fun-name tm-id))) + + (defun import-dom (rdf-dom start-revision &key (tm-id nil) (document-id *document-id*)) + "Imports the entire dom of a rdf-xml-file." (tm-id-p tm-id "import-dom") (let ((xml-base (get-xml-base rdf-dom)) (xml-lang (get-xml-lang rdf-dom)) (elem-name (get-node-name rdf-dom)) (elem-ns (dom:namespace-uri rdf-dom))) - (if (and (string= elem-ns *rdf-ns*) (string= elem-name "RDF")) (let ((children (child-nodes-or-text rdf-dom))) @@ -51,8 +89,8 @@ (loop for child across children do (import-node child tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang)))) + (import-node rdf-dom tm-id start-revision :document-id document-id + :xml-base xml-base :xml-lang xml-lang)))) (defun import-node (elem tm-id start-revision &key (document-id *document-id*) @@ -75,68 +113,241 @@ :psi (get-type-of-node-name elem) :ID nil)) (get-types-of-node-content elem tm-id fn-xml-base))) - (super-classes (get-super-classes-of-node-content elem tm-id xml-base))) - (let ((topic-stub (make-topic-stub-from-node about ID nodeID UUID - start-revision + (super-classes + (get-super-classes-of-node-content elem tm-id xml-base))) + (with-tm (start-revision document-id tm-id) + (let ((topic-stub + (make-topic-stub + about ID nodeID UUID start-revision xml-importer::tm + :document-id document-id))) + (map 'list #'(lambda(literal) + (make-occurrence topic-stub literal start-revision + tm-id :document-id document-id)) + literals) + (format t "~a~%" literals) + (map 'list #'(lambda(assoc) + (make-association topic-stub assoc xml-importer::tm + start-revision + :document-id document-id)) + associations) + (map 'list + #'(lambda(type) + (let ((type-topic + (make-topic-stub (getf type :psi) + (getf type :topicid) + nil nil start-revision + xml-importer::tm + :document-id document-id)) + (ID (getf type :ID))) + (make-instance-of-association topic-stub type-topic + ID start-revision + xml-importer::tm :document-id document-id))) + types) ;TODO: + ;*import standard topics from isidorus' rdf2tm namespace + ; (must be explicitly called by the user) ;*get-topic by topic id ;*make psis ;*if the topic does not exist create one with topic id ;*add psis - ;make instance-of associations - ;make topictype topics with topic id - ;make super-sub-class associations - ;make occurrencetype topics with topic id - ;make and add occurrences - ;make referenced topic with topic id - ;make and add associations + ;*make instance-of associations + reification + ;make super-sub-class associations + reification + ;*make occurrences + reification + ;*make associations + reification ;TODO: start recursion ... - (remove-node-properties-from-*_n-map* elem) - (or tm-id document-id topic-stub nodeID UUID literals ;TODO: remove - associations types super-classes))))) + (remove-node-properties-from-*_n-map* elem) + (or super-classes) ;TODO: remove + ))))) -(defun make-topic-stub-from-node (about ID nodeId UUID start-revision - &key (document-id *document-id*)) + +(defun make-instance-of-association (instance-top type-top reifier-id + start-revision tm + &key (document-id *document-id*)) + "Creates and returns an instance-of association." + (declare (TopicC type-top instance-top)) + (declare (TopicMapC tm)) + (let ((assoc-type + (get-item-by-psi *type-instance-psi*)) + (roletype-1 + (get-item-by-psi *type-psi*)) + (roletype-2 + (get-item-by-psi *instance-psi*))) + (let ((a-roles (list (list :instance-of roletype-1 + :player type-top) + (list :instance-of roletype-2 + :player instance-top)))) + (when reifier-id + (make-reification reifier-id instance-top type-top + assoc-type start-revision tm + :document-id document-id)) + (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of assoc-type + :roles a-roles))))) + + +(defun make-topic-stub (about ID nodeId UUID start-revision + tm &key (document-id *document-id*)) "Returns a topic corresponding to the passed parameters. When the searched topic does not exist there will be created one. - If about or ID is set there will aslo be created a new PSI." -; (let ((topic-id (or about ID nodeID UUID)) -; (psi-value (or about ID)) -; (err-pref "From make-topic-stub-from-node(): ")) -; (unless topic-id -; (error "~aone of about ID nodeID UUID must be set!" -; err-pref)) -; (elephant:ensure-transaction (:txn-nosync t) -; (let ((top (get-item-by-id topic-id :xtm-id document-id -; :revision start-revision))) -; (let ((topic-psis (map 'list #'d:uri (d:psis top)))) -; (if (and psi-value -; (not (find psi-value topic-psis :test #'string=))) -; (let ((psis (list (d::make-instance -; 'd:PersistentIdC -; :uri psi-value -; :start-revision start-revision)))) -; ;create only a new topic if there existed no one -; (d::make-instance 'd:TopicC -; :topicid topic-id -; :psis psis -; :xtm-id document-id -; :start-revision start-revision)) -; top)))))) -) - - -(defun make-occurrence-from-node (top literals start-revision - &key (document-id *document-id*)) -; (loop for literal in literals -; do (let ((type - ) - + If about or ID is set there will also be created a new PSI." + (declare (TopicMapC tm)) + (let ((topic-id (or about ID nodeID UUID)) + (psi-uri (or about ID))) + (let ((top (get-item-by-id topic-id :xtm-id document-id + :revision start-revision))) + (if top + top + (elephant:ensure-transaction (:txn-nosync t) + (let ((psi (when psi-uri + (make-instance 'PersistentIdC + :uri psi-uri + :start-revision start-revision)))) + (add-to-topicmap + tm + (make-construct 'TopicC + :topicid topic-id + :psis (when psi (list psi)) + :xtm-id document-id + :start-revision start-revision)))))))) + + +(defun make-lang-topic (lang tm-id start-revision tm + &key (document-id *document-id*)) + "Returns a topic with the topicid tm-id/lang. If no such topic exist + there will be created one." + (declare (TopicMapC tm)) + (when (and lang tm-id) + (tm-id-p tm-id "make-lang-topic") + (let ((psi-and-topic-id + (absolutize-value lang nil tm-id))) + (let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id + :revision start-revision))) + (if top + top + (make-topic-stub psi-and-topic-id nil nil nil start-revision + tm :document-id document-id)))))) + + +(defun make-association (top association tm start-revision + &key (document-id *document-id*)) + "Creates an association depending on the given parameters and + returns the elephat-associaton object." + (declare (TopicC top)) + (declare (TopicMapC tm)) + (let ((type (getf association :type)) + (player-id (getf association :topicid)) + (player-psi (getf association :psi)) + (ID (getf association :ID))) + (let ((player-1 (make-topic-stub player-psi player-id nil nil start-revision + tm :document-id document-id)) + (role-type-1 (get-item-by-psi *rdf2tm-object*)) + (role-type-2 (get-item-by-psi *rdf2tm-subject*)) + (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) + (list :instance-of role-type-2 + :player top)))) + (when ID + (make-reification ID top type-top player-1 start-revision + tm :document-id document-id)) + (add-to-topicmap tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of type-top + :roles roles)))))) + + +(defun make-association-with-nodes (subject-topic object-topic + associationtype-topic tm start-revision) + "Creates an association with two roles that contains the given players." + (declare (TopicC subject-topic object-topic associationtype-topic)) + (declare (TopicMapC tm)) + (let ((role-type-1 (get-item-by-psi *rdf2tm-subject*)) + (role-type-2 (get-item-by-psi *rdf2tm-object*))) + (let ((roles (list (list :instance-of role-type-1 + :player subject-topic) + (list :instance-of role-type-2 + :player object-topic)))) + (add-to-topicmap tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of associationtype-topic + :roles roles))))) + + +(defun make-reification (reifier-id subject object predicate start-revision tm + &key document-id) + "Creates a reification construct." + (declare (string reifier-id)) + (declare ((or OccurrenceC TopicC) object)) + (declare (TopicC subject predicate)) + (declare (TopicMapC tm)) + (let ((reifier (make-topic-stub reifier-id nil nil nil start-revision tm + :document-id document-id)) + (predicate-arc (make-topic-stub *rdf-predicate* nil nil nil start-revision + tm :document-id document-id)) + (object-arc (make-topic-stub *rdf-object* nil nil nil start-revision + tm :document-id document-id)) + (subject-arc (make-topic-stub *rdf-object* nil nil nil start-revision + tm :document-id document-id)) + (statement (make-topic-stub *rdf-statement* nil nil nil start-revision + tm :document-id document-id))) + (make-instance-of-association reifier statement nil start-revision tm + :document-id document-id) + (make-association-with-nodes reifier subject subject-arc tm start-revision) + (make-association-with-nodes reifier predicate-arc predicate + tm start-revision) + (if (typep object 'TopicC) + (make-association-with-nodes reifier object object-arc + tm start-revision) + (make-construct 'OccurrenceC + :start-revision start-revision + :topic reifier + :themes (themes object) + :instance-of (instance-of object) + :charvalue (charvalue object) + :datatype (datatype object))))) + + +(defun make-occurrence (top literal start-revision tm-id + &key (document-id *document-id*)) + "Creates an accorrence from the literal list and returns + the created elephant-occurrence-object." + (declare (TopicC top)) + (tm-id-p tm-id "make-occurrence") + (with-tm (start-revision document-id tm-id) + (let ((type (getf literal :type)) + (value (getf literal :value)) + (lang (getf literal :lang)) + (datatype (getf literal :datatype)) + (ID (getf literal :ID))) + (let ((type-top (make-topic-stub type nil nil nil start-revision + xml-importer::tm + :document-id document-id)) + (lang-top (make-lang-topic lang tm-id start-revision + xml-importer::tm + :document-id document-id))) + (let ((occurrence + (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes (when lang-top + (list lang-top)) + :instance-of type-top + :charvalue value + :datatype datatype))) + (when ID + (make-reification ID top type-top occurrence start-revision + xml-importer::tm :document-id document-id)) + occurrence))))) + (defun get-literals-of-node-content (node tm-id xml-base xml-lang) "Returns a list of literals that is produced of a node's content." Added: trunk/src/xml/rdf/rdf_core_psis.xtm ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/rdf_core_psis.xtm Fri Jul 31 18:41:02 2009 @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + subject + + + + + + + object + + + + Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Fri Jul 31 18:41:02 2009 @@ -14,7 +14,19 @@ *xml-ns* *xmlns-ns* *xml-string* - *rdf2tm-ns*) + *rdf2tm-ns* + *xtm2.0-ns* + *type-instance-psi* + *type-psi* + *instance-psi* + *rdf-statement* + *rdf-object* + *rdf-subject* + *rdf-predicate* + *rdf2tm-object* + *rdf2tm-subject*) + (:import-from :xml-constants + *rdf_core_psis.xtm*) (:import-from :xml-constants *core_psis.xtm*) (:import-from :xml-tools @@ -39,7 +51,12 @@ node-to-string) (:import-from :xml-importer get-uuid - get-store-spec) + get-store-spec + with-tm + from-topic-elem-to-stub) + (:import-from :isidorus-threading + with-reader-lock + with-writer-lock) (:import-from :exceptions missing-reference-error duplicate-identifier-error)) @@ -59,6 +76,8 @@ "range" "range" "label" "comment" "member" "seeAlso" "isDefinedBy")) +(defvar *rdf-core-xtm* "rdf_core.xtm") + (defvar *_n-map* nil) From lgiessmann at common-lisp.net Fri Jul 31 23:03:33 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 31 Jul 2009 19:03:33 -0400 Subject: [isidorus-cvs] r102 - trunk/src/xml/rdf Message-ID: Author: lgiessmann Date: Fri Jul 31 19:03:33 2009 New Revision: 102 Log: fixed some problem with getting literals Modified: trunk/src/xml/rdf/importer.lisp Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Fri Jul 31 19:03:33 2009 @@ -124,7 +124,6 @@ (make-occurrence topic-stub literal start-revision tm-id :document-id document-id)) literals) - (format t "~a~%" literals) (map 'list #'(lambda(assoc) (make-association topic-stub assoc xml-importer::tm start-revision @@ -367,11 +366,18 @@ :ns-uri *rdf2tm-ns*)) (type (get-ns-attribute property "type")) (prop-literals (get-literals-of-property - property nil))) - (and (or (or datatype - (string= parseType "Literal")) - (not (or nodeID resource UUID parseType))) - (not (or type prop-literals)))) + property nil)) + (prop-content (child-nodes-or-text property))) + (and (or datatype + (string= parseType "Literal") + (and (not (or nodeID resource UUID parseType)) + (or (not prop-content) + (stringp prop-content)))) + (not (or prop-literals type)) + (string/= parseType "Collection") + (string/= parseType "Resource"))) + + collect (let ((content (child-nodes-or-text property)) (ID (get-absolute-attribute property tm-id fn-xml-base "ID"))