From lgiessmann at common-lisp.net Tue Nov 9 20:00:21 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 09 Nov 2010 15:00:21 -0500 Subject: [isidorus-cvs] r334 - in trunk/src: . base-tools model xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Tue Nov 9 15:00:20 2010 New Revision: 334 Log: added the file trivial-queries.lisp => currently it contains trivial query functions for roles and associations and an invoke-on method for characteristics that invokes a method with the characteristics value as parameter, additionally a cast-operation can be passed to cast the string-value to a certain type, e.g. integer. Added: trunk/src/base-tools/ trunk/src/base-tools/base-tools.lisp trunk/src/model/trivial-queries.lisp Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/tools.lisp Added: trunk/src/base-tools/base-tools.lisp ============================================================================== --- (empty file) +++ trunk/src/base-tools/base-tools.lisp Tue Nov 9 15:00:20 2010 @@ -0,0 +1,33 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(defpackage :base-tools + (:use :cl) + (:nicknames :tools) + (:export :push-string + :when-do)) + +(in-package :base-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))) + + +(defmacro when-do (result-bounding condition-statement do-with-result) + "Executes the first statement and stores its result in the variable result. + If result isn't nil the second statement is called. + The second statement can use the variable tools:result as a parameter." + `(let ((,result-bounding ,condition-statement)) + (if ,result-bounding + ,do-with-result + nil))) + Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue Nov 9 15:00:20 2010 @@ -27,12 +27,16 @@ (:file "xml-constants" :depends-on ("xml/xtm/core_psis.xtm" "constants")) + (:module "base-tools" + :components ((:file "base-tools"))) (:module "model" :components ((:file "exceptions") (:file "datamodel" :depends-on ("exceptions")) + (:file "trivial-queries" + :depends-on ("datamodel")) (:file "changes" - :depends-on ("datamodel")) + :depends-on ("datamodel" "trivial-queries")) (:file "model_tools" :depends-on ("exceptions"))) :depends-on ("constants")) @@ -65,7 +69,8 @@ :depends-on ("constants" "xml-constants" "model" - "threading")) + "threading" + "base-tools")) (:module "atom" :components ((:file "atom") ;; (:file "configuration" Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 9 15:00:20 2010 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :datamodel - (:use :cl :elephant :constants) + (:use :cl :elephant :constants :base-tools) (:nicknames :d) (:import-from :exceptions duplicate-identifier-error @@ -152,10 +152,22 @@ :get-all-associations :get-all-tms - ;;globals :*TM-REVISION* - :*CURRENT-XTM*)) + :*CURRENT-XTM* + + ;;trivial-queries + :roles-by-type + :roles-by-player + :filter-associations-by-type + :filter-associations-by-role + :associations-of + :instance-of-associations + :supertype-associations + :direct-supertypes + :supertypes + :direct-instance-of + :invoke-on)) (in-package :datamodel) Added: trunk/src/model/trivial-queries.lisp ============================================================================== --- (empty file) +++ trunk/src/model/trivial-queries.lisp Tue Nov 9 15:00:20 2010 @@ -0,0 +1,239 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(in-package :datamodel) + + +(defgeneric roles-by-type (construct role-type &key revision) + (:documentation "Returns all roles of the passed topic or + association that is of the specified role-type. + If role-type is set to nil all roles are returned.")) + + +(defmethod roles-by-type ((construct TopicC) role-type &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-type)) + (if role-type + (remove-if #'null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + role-type) + role)) + (player-in-roles construct :revision revision))) + (player-in-roles construct :revision revision))) + + +(defmethod roles-by-type ((construct AssociationC) role-type + &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-type)) + (if role-type + (remove-if #'null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + role-type) + role)) + (roles construct :revision revision))) + (roles construct :revision revision))) + + +(defgeneric roles-by-player (construct role-player &key revision) + (:documentation "Returns all roles that contains the corresponding player. + If the player is set to nil all roles are returned.") + (:method ((construct AssociationC) role-player &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-player)) + (if role-player + (remove-if #'null + (map 'list #'(lambda(role) + (when (eql (player role :revision revision) + role-player) + role)) + (roles construct :revision revision))) + (roles construct :revision revision)))) + + +(defun filter-associations-by-type (associations association-type + &key (revision *TM-REVISION*)) + "Returns a list of associations that are an instance-of of the given + association-type. If association-type is set to nil, all associations + are returned." + (declare (List associations) + (type (or Null TopicC) association-type) + (integer revision)) + (if association-type + (remove-if #'(lambda(assoc) + (not (eql (instance-of assoc :revision revision) + association-type))) + associations) + associations)) + + +(defun filter-associations-by-role (associations role-type role-player + &key (revision *TM-REVISION*)) + "Returns associations that have a role corresponding to the passed + values. If any of the passed role-values is set to nil, it won't be used + for the evaluation of the result." + (declare (List associations) + (type (or Null TopicC) role-type role-player)) + (remove-if #'null + (intersection + (map 'list #'(lambda(assoc) + (when (roles-by-type assoc role-type + :revision revision) + assoc)) + associations) + (map 'list #'(lambda(assoc) + (when (roles-by-player assoc role-player + :revision revision) + assoc)) + associations)))) + + +(defgeneric associations-of (construct role-type association-type + other-role-type other-player + &key revision) + (:documentation "Returns all associations of the passed topic (construct) + that corresponds to the given values. + If any of the passed values is set to nil, it won't be + used to evaluate the result.") + (:method ((construct TopicC) role-type association-type other-role-type + other-player &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) role-type association-type + other-role-type other-player)) + (let ((assocs-by-role (map 'list #'(lambda(role) + (parent role :revision revision)) + (roles-by-type construct role-type + :revision revision)))) + (let ((assocs-by-type + (filter-associations-by-type assocs-by-role association-type + :revision revision))) + (filter-associations-by-role assocs-by-type other-role-type + other-player :revision revision))))) + + +(defgeneric instance-of-associations (construct &key revision) + (:documentation "Returns all type-instance associations of + the passed instance topic.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((type-top + (get-item-by-psi *type-psi* :revision revision :error-if-nil t)) + (instance-top + (get-item-by-psi *instance-psi* :revision revision :error-if-nil t)) + (type-instance-top + (get-item-by-psi *type-instance-psi* :revision revision + :error-if-nil t))) + (let ((possible-assocs + (map 'list #'(lambda(role) + (parent role :revision revision)) + (roles-by-type construct instance-top :revision revision)))) + (let ((type-instance-assocs + (filter-associations-by-type possible-assocs type-instance-top + :revision revision))) + (filter-associations-by-role type-instance-assocs type-top nil + :revision revision)))))) + + +(defgeneric supertype-associations (construct &key revision) + (:documentation "Returns all supertype-subtype associations of + the passed subtype topic.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((supertype-top + (get-item-by-psi *supertype-psi* :revision revision :error-if-nil t)) + (subtype-top + (get-item-by-psi *subtype-psi* :revision revision :error-if-nil t)) + (supertype-subtype-top + (get-item-by-psi *supertype-subtype-psi* :revision revision + :error-if-nil t))) + (let ((possible-assocs + (map 'list #'(lambda(role) + (parent role :revision revision)) + (roles-by-type construct subtype-top :revision revision)))) + (let ((type-instance-assocs + (filter-associations-by-type possible-assocs supertype-subtype-top + :revision revision))) + (filter-associations-by-role type-instance-assocs supertype-top nil + :revision revision)))))) + + +(defgeneric direct-supertypes (construct &key revision) + (:documentation "Returns all direct super type topics of the passed + construct.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((assocs (supertype-associations construct :revision revision))) + (remove-if #'null + (map 'list #'(lambda(assoc) + (find-if-not + #'(lambda(role) + (eql (player role :revision revision) + construct)) + (roles assoc :revision revision))) + assocs))))) + + +(defgeneric supertypes (construct &key revision valid-supertypes) + (:documentation "Returns all super type topics of the passed + construct, also the transitive ones.") + (:method ((construct TopicC) &key (revision *TM-REVISION*) valid-supertypes) + (declare (integer revision)) + (let ((direct-super-types (direct-supertypes construct :revision revision))) + (let ((current-valid-super-types + (append valid-supertypes direct-super-types))) + (let ((recursive-super-types + (loop for direct-super-type in direct-super-types + append (supertypes + direct-super-type :revision revision + :valid-supertypes current-valid-super-types)))) + (remove-duplicates + (remove-if #'null recursive-super-types))))))) + + +(defgeneric direct-instance-of (construct &key revision) + (:documentation "Returns all direct type topics of the passed instance topic.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((assocs (instance-of-associations construct :revision revision))) + (remove-if #'null + (map 'list #'(lambda(assoc) + (find-if-not + #'(lambda(role) + (eql (player role :revision revision) + construct)) + (roles assoc :revision revision))) + assocs))))) + + +(defmethod instance-of (construct &key (revision *TM-REVISION*)) + "Returns all type topics of the passed construct and their super-types." + (declare (integer revision)) + (let ((all-super-types (supertypes construct :revision revision))) + (let ((all-types + (loop for topic in (append (list construct) all-super-types) + append (direct-instance-of topic :revision revision)))) + (remove-duplicates + (remove-if #'null all-types))))) + + +(defgeneric invoke-on (construct main-operation &key cast-operation) + (:documentation "Invokes the passed main operation on the characteristic's + value. + If cast-operation is set to a function the characteristic's + value is first casted by the cast-operation to another type + and afterwords processed by main-opertion.") + (:method ((construct TopicC) (main-operation Function) &key cast-operation) + (declare (type (or Null Function) cast-operation)) + (let ((value (if cast-operation + (apply cast-operation (list (charvalue construct))) + (charvalue construct)))) + (funcall main-operation value)))) \ 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 Tue Nov 9 15:00:20 2010 @@ -8,7 +8,8 @@ ;;+----------------------------------------------------------------------------- (defpackage :rdf-importer - (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel) + (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel + :base-tools) (:import-from :constants *rdf-ns* *rdfs-ns* @@ -78,7 +79,6 @@ absolutize-value absolutize-id concatenate-uri - push-string node-to-string) (:import-from :xml-importer get-uuid Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Tue Nov 9 15:00:20 2010 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :xml-tools - (:use :cl :cxml) + (:use :cl :cxml :base-tools) (:import-from :constants *xml-ns* *xmlns-ns* @@ -29,17 +29,10 @@ :absolutize-value :absolutize-id :concatenate-uri - :push-string :node-to-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 '/'." From lgiessmann at common-lisp.net Tue Nov 9 20:52:20 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 09 Nov 2010 15:52:20 -0500 Subject: [isidorus-cvs] r335 - trunk/src/model Message-ID: Author: lgiessmann Date: Tue Nov 9 15:52:19 2010 New Revision: 335 Log: changed the function invoke-on, so an additional cast-operation can't be passed, since the casting can be done in the main-operation directly; added the functions: names-by-type, names-by-value, occurrences-by-type, occurrences-by-value, characterisitcs-by-type, characterisitcs-by-value; added the condition bad-type-error Modified: trunk/src/model/datamodel.lisp trunk/src/model/exceptions.lisp trunk/src/model/trivial-queries.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 9 15:52:19 2010 @@ -15,7 +15,8 @@ object-not-found-error missing-argument-error not-mergable-error - tm-reference-error) + tm-reference-error + bad-type-error) (:import-from :constants *xml-string* *instance-psi*) @@ -167,7 +168,13 @@ :direct-supertypes :supertypes :direct-instance-of - :invoke-on)) + :invoke-on + :names-by-type + :occurrencs-by-type + :characteristics-by-type + :occurrences-by-value + :names-by-value + :characteristics-by-value)) (in-package :datamodel) @@ -648,6 +655,14 @@ :new-reference new-reference)) +(defun make-bad-type-condition (message expected-type result-object) + (make-condition + 'bad-type-error + :message message + :expected-type expected-type + :result-object result-object)) + + (defun make-not-mergable-condition (message construct-1 construct-2) "Returns a not-mergable-condition with the passed arguments." (make-condition 'not-mergable-error Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Tue Nov 9 15:52:19 2010 @@ -16,7 +16,8 @@ :object-not-found-error :not-mergable-error :missing-argument-error - :tm-reference-error)) + :tm-reference-error + :bad-type-error)) (in-package :exceptions) @@ -103,6 +104,20 @@ (new-reference :initarg :new-reference :accessor new-reference)) - (:documentation "Thrown of the referenced-construct is already owned by another + (:documentation "Thrown if the referenced-construct is already owned by another TM-construct (existing-reference) and is going to be referenced - by a second TM-construct (new-reference) at the same time.")) \ No newline at end of file + by a second TM-construct (new-reference) at the same time.")) + + +(define-condition bad-type-error (error) + ((message + :initarg :message + :accessor message) + (expected-type + :initarg :expected-type + :accessor expected-type) + (result-object + :initarg :result-object + :accessor result-object)) + (:documentation "Thrown if a bad result object with respect to the expected + type was found.")) \ No newline at end of file Modified: trunk/src/model/trivial-queries.lisp ============================================================================== --- trunk/src/model/trivial-queries.lisp (original) +++ trunk/src/model/trivial-queries.lisp Tue Nov 9 15:52:19 2010 @@ -225,15 +225,88 @@ (remove-if #'null all-types))))) -(defgeneric invoke-on (construct main-operation &key cast-operation) +(defgeneric invoke-on (construct operation) (:documentation "Invokes the passed main operation on the characteristic's value. If cast-operation is set to a function the characteristic's value is first casted by the cast-operation to another type and afterwords processed by main-opertion.") - (:method ((construct TopicC) (main-operation Function) &key cast-operation) - (declare (type (or Null Function) cast-operation)) - (let ((value (if cast-operation - (apply cast-operation (list (charvalue construct))) - (charvalue construct)))) - (funcall main-operation value)))) \ No newline at end of file + (:method ((construct TopicC) (operation Function)) + (funcall operation (charvalue construct)))) + + +(defgeneric names-by-type (construct type-identifier &key revision) + (:documentation "Returns all names that are of the corresponding type.") + (:method ((construct TopicC) (type-identifier IdentifierC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((type-topic (identified-construct type-identifier :revision revision))) + (unless (typep type-topic 'TopicC) + (error (make-bad-type-condition (format nil "from name-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic))) + (let ((results + (map 'list #'(lambda(name) + (when (instance-of name :revision revision) + name)) + (names construct :revision revision)))) + (remove-if #'null results))))) + + +(defgeneric occurrences-by-type (construct type-identifier &key revision) + (:documentation "Returns all names that are of the corresponding type.") + (:method ((construct TopicC) (type-identifier IdentifierC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((type-topic (identified-construct type-identifier :revision revision))) + (unless (typep type-topic 'TopicC) + (error (make-bad-type-condition (format nil "from occurrence-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic))) + (let ((results + (map 'list #'(lambda(occ) + (when (instance-of occ :revision revision) + occ)) + (occurrences construct :revision revision)))) + (remove-if #'null results))))) + + +(defgeneric characteristic-by-type (construct type-identifier &key revision) + (:documentation "Returns all characteristics that are of the + corresponding type.") + (:method ((construct TopicC) (type-identifier IdentifierC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (union (names-by-type construct type-identifier :revision revision) + (occurrences-by-type construct type-identifier :revision revision)))) + + +(defgeneric occurrences-by-value (construct filter &key revision) + (:documentation "Returns a list of all occurrences of the passed + topic, that return a true value when calling filter + on their charvalue.") + (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*)) + (let ((results + (map 'list #'(lambda(occ) + (when (invoke-on occ filter) + occ)) + (occurrences construct :revision revision)))) + (remove-if #'null results)))) + + +(defgeneric names-by-value (construct filter &key revision) + (:documentation "Returns a list of all names of the passed + topic, that return a true value when calling filter + on their charvalue.") + (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*)) + (let ((results + (map 'list #'(lambda(name) + (when (invoke-on name filter) + name)) + (names construct :revision revision)))) + (remove-if #'null results)))) + + +(defgeneric characteristic-by-value (construct filter &key revision) + (:documentation "Returns a list of all characteristics of the passed + topic, that return a true value when calling filter.") + (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (union (names-by-value construct filter :revision revision) + (occurrences-by-value construct filter :revision revision)))) \ No newline at end of file From lgiessmann at common-lisp.net Wed Nov 10 08:32:08 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 10 Nov 2010 03:32:08 -0500 Subject: [isidorus-cvs] r336 - in trunk/src: . TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Wed Nov 10 03:32:07 2010 New Revision: 336 Log: added the fundamental module-structure including all files for the TM-SPARQL-interface and the corresponding unit-tests Added: trunk/src/TM-SPARQL/ trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_tokenizer.lisp trunk/src/unit_tests/sparql_test.lisp trunk/src/unit_tests/trivial_queries_test.lisp Modified: trunk/src/isidorus.asd Added: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- (empty file) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Nov 10 03:32:07 2010 @@ -0,0 +1,10 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(in-package :TM-SPARQL) Added: trunk/src/TM-SPARQL/sparql_tokenizer.lisp ============================================================================== --- (empty file) +++ trunk/src/TM-SPARQL/sparql_tokenizer.lisp Wed Nov 10 03:32:07 2010 @@ -0,0 +1,14 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(defpackage :TM-SPARQL + (:use :cl :datamodel)) + + +(in-package :TM-SPARQL) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Nov 10 03:32:07 2010 @@ -40,6 +40,11 @@ (:file "model_tools" :depends-on ("exceptions"))) :depends-on ("constants")) + (:module "TM-SPARQL" + :components ((:file "sparql" + :depends-on ("sparql_tokenizer")) + (:file "sparql_tokenizer")) + :depends-on ("constants" "base-tools" "model")) (:module "xml" :components ((:module "xtm" :components ((:file "tools") @@ -161,6 +166,10 @@ :depends-on ("fixtures")) (:file "datamodel_test" :depends-on ("fixtures")) + (:file "sparql_test" + :depends-on ("fixtures")) + (:file "trivial_queries_test" + :depends-on ("fixtures")) (:file "reification_test" :depends-on ("fixtures" "unittests-constants"))) :depends-on ("atom" Added: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/sparql_test.lisp Wed Nov 10 03:32:07 2010 @@ -0,0 +1,28 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(defpackage :sparql-test + (:use :cl + :it.bese.FiveAM + :TM-SPARQL) + (:export :run-sparql-tests + :sparql-tests)) + + +(in-package :sparql-test) + + +(def-suite sparql-test + :description "tests various key functions of the TM-SPARQL module") + +(in-suite sparql-test) + + +(defun run-sparql-tests () + (it.bese.fiveam:run! 'sparql-test:sparql-tests)) \ No newline at end of file Added: trunk/src/unit_tests/trivial_queries_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/trivial_queries_test.lisp Wed Nov 10 03:32:07 2010 @@ -0,0 +1,29 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(defpackage :trivial-queries-test + (:use :cl + :it.bese.FiveAM + :datamodel) + (:export :run-trivial-queries-tests + :trivial-queries-tests)) + + +(in-package :trivial-queries-test) + + +(def-suite trivial-queries-test + :description "tests various key functions of the trivial-query-test of + the datamodel module") + +(in-suite trivial-queries-test) + + +(defun run-trivial-queries-tests () + (it.bese.fiveam:run! 'trivial-queries-test:trivial-queries-tests)) \ No newline at end of file From lgiessmann at common-lisp.net Thu Nov 11 08:47:23 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 11 Nov 2010 03:47:23 -0500 Subject: [isidorus-cvs] r337 - in trunk/src: . base-tools model unit_tests Message-ID: Author: lgiessmann Date: Thu Nov 11 03:47:23 2010 New Revision: 337 Log: fixed ticket #90 => added unit-tests for the trivial-query part of the datamodel; added some functionality and fixed some bugs in the trivial-query part. Modified: trunk/src/base-tools/base-tools.lisp trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/model/trivial-queries.lisp trunk/src/unit_tests/fixtures.lisp trunk/src/unit_tests/poems.xtm trunk/src/unit_tests/trivial_queries_test.lisp trunk/src/unit_tests/unittests-constants.lisp Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Thu Nov 11 03:47:23 2010 @@ -11,7 +11,9 @@ (:use :cl) (:nicknames :tools) (:export :push-string - :when-do)) + :when-do + :remove-null + :full-path)) (in-package :base-tools) @@ -31,3 +33,23 @@ ,do-with-result nil))) + +(defun remove-null (lst) + "Removes all null values from the passed list." + (remove-if #'null lst)) + + +(defun full-path (pathname) + "Returns a string that represents the full path of the passed + CL:Pathname construct." + (declare (CL:Pathname pathname)) + (let ((segments + (remove-if #'null + (map 'list #'(lambda(item) + (when (stringp item) + (concatenate 'string "/" item))) + (pathname-directory pathname)))) + (full-path-string "")) + (dolist (segment segments) + (push-string segment full-path-string)) + (concatenate 'string full-path-string "/" (pathname-name pathname)))) \ No newline at end of file Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Thu Nov 11 03:47:23 2010 @@ -39,7 +39,7 @@ :depends-on ("datamodel" "trivial-queries")) (:file "model_tools" :depends-on ("exceptions"))) - :depends-on ("constants")) + :depends-on ("constants" "base-tools")) (:module "TM-SPARQL" :components ((:file "sparql" :depends-on ("sparql_tokenizer")) @@ -177,7 +177,9 @@ "model" "xml" "json" - "threading")) + "threading" + "base-tools" + "TM-SPARQL")) (:module "json" :components ((:file "json_exporter" :depends-on ("json_tmcl_constants")) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Thu Nov 11 03:47:23 2010 @@ -170,11 +170,13 @@ :direct-instance-of :invoke-on :names-by-type - :occurrencs-by-type + :occurrences-by-type :characteristics-by-type :occurrences-by-value :names-by-value - :characteristics-by-value)) + :characteristics-by-value + :isa + :aka)) (in-package :datamodel) Modified: trunk/src/model/trivial-queries.lisp ============================================================================== --- trunk/src/model/trivial-queries.lisp (original) +++ trunk/src/model/trivial-queries.lisp Thu Nov 11 03:47:23 2010 @@ -21,12 +21,12 @@ (declare (integer revision) (type (or Null TopicC) role-type)) (if role-type - (remove-if #'null - (map 'list #'(lambda(role) - (when (eql (instance-of role :revision revision) - role-type) - role)) - (player-in-roles construct :revision revision))) + (remove-null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + role-type) + role)) + (player-in-roles construct :revision revision))) (player-in-roles construct :revision revision))) @@ -35,28 +35,35 @@ (declare (integer revision) (type (or Null TopicC) role-type)) (if role-type - (remove-if #'null - (map 'list #'(lambda(role) - (when (eql (instance-of role :revision revision) - role-type) - role)) - (roles construct :revision revision))) + (remove-null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + role-type) + role)) + (roles construct :revision revision))) (roles construct :revision revision))) -(defgeneric roles-by-player (construct role-player &key revision) +(defgeneric roles-by-player (construct role-player + &key role-player-is-type revision) (:documentation "Returns all roles that contains the corresponding player. If the player is set to nil all roles are returned.") - (:method ((construct AssociationC) role-player &key (revision *TM-REVISION*)) + (:method ((construct AssociationC) role-player + &key role-player-is-type (revision *TM-REVISION*)) (declare (integer revision) - (type (or Null TopicC) role-player)) + (type (or Null TopicC) role-player) + (boolean role-player-is-type)) (if role-player - (remove-if #'null - (map 'list #'(lambda(role) - (when (eql (player role :revision revision) - role-player) - role)) - (roles construct :revision revision))) + (remove-null + (map 'list #'(lambda(role) + (if role-player-is-type + (when (isa (player role :revision revision) + role-player) + role) + (when (eql (player role :revision revision) + role-player) + role))) + (roles construct :revision revision))) (roles construct :revision revision)))) @@ -77,38 +84,44 @@ (defun filter-associations-by-role (associations role-type role-player - &key (revision *TM-REVISION*)) + &key role-player-is-type (revision *TM-REVISION*)) "Returns associations that have a role corresponding to the passed values. If any of the passed role-values is set to nil, it won't be used for the evaluation of the result." (declare (List associations) - (type (or Null TopicC) role-type role-player)) - (remove-if #'null - (intersection - (map 'list #'(lambda(assoc) - (when (roles-by-type assoc role-type - :revision revision) - assoc)) - associations) - (map 'list #'(lambda(assoc) - (when (roles-by-player assoc role-player - :revision revision) - assoc)) - associations)))) + (type (or Null TopicC) role-type role-player) + (boolean role-player-is-type)) + (remove-null + (intersection + (map 'list #'(lambda(assoc) + (when (roles-by-type assoc role-type + :revision revision) + assoc)) + associations) + (map 'list #'(lambda(assoc) + (when (roles-by-player + assoc role-player + :role-player-is-type role-player-is-type + :revision revision) + assoc)) + associations)))) (defgeneric associations-of (construct role-type association-type other-role-type other-player - &key revision) + &key other-role-player-is-type + revision) (:documentation "Returns all associations of the passed topic (construct) that corresponds to the given values. If any of the passed values is set to nil, it won't be used to evaluate the result.") (:method ((construct TopicC) role-type association-type other-role-type - other-player &key (revision *TM-REVISION*)) + other-player &key other-role-player-is-type + (revision *TM-REVISION*)) (declare (integer revision) (type (or Null TopicC) role-type association-type - other-role-type other-player)) + other-role-type other-player) + (boolean other-role-player-is-type)) (let ((assocs-by-role (map 'list #'(lambda(role) (parent role :revision revision)) (roles-by-type construct role-type @@ -116,8 +129,10 @@ (let ((assocs-by-type (filter-associations-by-type assocs-by-role association-type :revision revision))) - (filter-associations-by-role assocs-by-type other-role-type - other-player :revision revision))))) + (filter-associations-by-role + assocs-by-type other-role-type other-player + :role-player-is-type other-role-player-is-type + :revision revision))))) (defgeneric instance-of-associations (construct &key revision) @@ -172,14 +187,18 @@ (:method ((construct TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) (let ((assocs (supertype-associations construct :revision revision))) - (remove-if #'null - (map 'list #'(lambda(assoc) - (find-if-not - #'(lambda(role) - (eql (player role :revision revision) - construct)) - (roles assoc :revision revision))) - assocs))))) + (let ((other-roles + (remove-null + (map 'list + #'(lambda(assoc) + (find-if-not #'(lambda(role) + (eql (player role :revision revision) + construct)) + (roles assoc :revision revision))) + assocs)))) + (remove-null (map 'list #'(lambda(role) + (player role :revision revision)) + other-roles)))))) (defgeneric supertypes (construct &key revision valid-supertypes) @@ -196,7 +215,8 @@ direct-super-type :revision revision :valid-supertypes current-valid-super-types)))) (remove-duplicates - (remove-if #'null recursive-super-types))))))) + (remove-null (union recursive-super-types + current-valid-super-types)))))))) (defgeneric direct-instance-of (construct &key revision) @@ -204,25 +224,27 @@ (:method ((construct TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) (let ((assocs (instance-of-associations construct :revision revision))) - (remove-if #'null - (map 'list #'(lambda(assoc) - (find-if-not - #'(lambda(role) - (eql (player role :revision revision) - construct)) - (roles assoc :revision revision))) - assocs))))) + (let ((other-roles + (remove-null + (map 'list #'(lambda(assoc) + (find-if-not #'(lambda(role) + (eql (player role :revision revision) + construct)) + (roles assoc :revision revision))) + assocs)))) + (remove-null (map 'list #'(lambda(role) + (player role :revision revision)) + other-roles)))))) (defmethod instance-of (construct &key (revision *TM-REVISION*)) "Returns all type topics of the passed construct and their super-types." (declare (integer revision)) - (let ((all-super-types (supertypes construct :revision revision))) - (let ((all-types - (loop for topic in (append (list construct) all-super-types) - append (direct-instance-of topic :revision revision)))) - (remove-duplicates - (remove-if #'null all-types))))) + (let ((direct-types (direct-instance-of construct :revision revision))) + (let ((supertypes-of-types + (loop for type in direct-types + append (supertypes type :revision revision)))) + (union direct-types supertypes-of-types)))) (defgeneric invoke-on (construct operation) @@ -231,50 +253,37 @@ If cast-operation is set to a function the characteristic's value is first casted by the cast-operation to another type and afterwords processed by main-opertion.") - (:method ((construct TopicC) (operation Function)) + (:method ((construct CharacteristicC) (operation Function)) (funcall operation (charvalue construct)))) -(defgeneric names-by-type (construct type-identifier &key revision) +(defgeneric names-by-type (construct nametype &key revision) (:documentation "Returns all names that are of the corresponding type.") - (:method ((construct TopicC) (type-identifier IdentifierC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (let ((type-topic (identified-construct type-identifier :revision revision))) - (unless (typep type-topic 'TopicC) - (error (make-bad-type-condition (format nil "from name-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic))) - (let ((results - (map 'list #'(lambda(name) - (when (instance-of name :revision revision) - name)) - (names construct :revision revision)))) - (remove-if #'null results))))) + (:method ((construct TopicC) nametype &key (revision *TM-REVISION*)) + (declare (integer revision) + (type (or Null TopicC) nametype)) + (remove-if-not #'(lambda(name) + (eql nametype (instance-of name :revision revision))) + (names construct :revision revision)))) -(defgeneric occurrences-by-type (construct type-identifier &key revision) +(defgeneric occurrences-by-type (construct occurrencetype &key revision) (:documentation "Returns all names that are of the corresponding type.") - (:method ((construct TopicC) (type-identifier IdentifierC) + (:method ((construct TopicC) (occurrencetype TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) - (let ((type-topic (identified-construct type-identifier :revision revision))) - (unless (typep type-topic 'TopicC) - (error (make-bad-type-condition (format nil "from occurrence-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic))) - (let ((results - (map 'list #'(lambda(occ) - (when (instance-of occ :revision revision) - occ)) - (occurrences construct :revision revision)))) - (remove-if #'null results))))) + (remove-if-not #'(lambda(occ) + (eql occurrencetype (instance-of occ :revision revision))) + (occurrences construct :revision revision)))) -(defgeneric characteristic-by-type (construct type-identifier &key revision) +(defgeneric characteristics-by-type (construct chartype &key revision) (:documentation "Returns all characteristics that are of the corresponding type.") - (:method ((construct TopicC) (type-identifier IdentifierC) - &key (revision *TM-REVISION*)) + (:method ((construct TopicC) (chartype TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) - (union (names-by-type construct type-identifier :revision revision) - (occurrences-by-type construct type-identifier :revision revision)))) + (union (names-by-type construct chartype :revision revision) + (occurrences-by-type construct chartype :revision revision)))) (defgeneric occurrences-by-value (construct filter &key revision) @@ -287,7 +296,7 @@ (when (invoke-on occ filter) occ)) (occurrences construct :revision revision)))) - (remove-if #'null results)))) + (remove-null results)))) (defgeneric names-by-value (construct filter &key revision) @@ -300,13 +309,33 @@ (when (invoke-on name filter) name)) (names construct :revision revision)))) - (remove-if #'null results)))) + (remove-null results)))) -(defgeneric characteristic-by-value (construct filter &key revision) +(defgeneric characteristics-by-value (construct filter &key revision) (:documentation "Returns a list of all characteristics of the passed topic, that return a true value when calling filter.") (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*)) (declare (integer revision)) (union (names-by-value construct filter :revision revision) - (occurrences-by-value construct filter :revision revision)))) \ No newline at end of file + (occurrences-by-value construct filter :revision revision)))) + + +(defgeneric isa (construct type &key revision) + (:documentation "Returns all types if the passed construct + is of the specified type.") + (:method ((construct TopicC) (type TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((all-types (instance-of construct :revision revision))) + (when (find type all-types) + all-types)))) + + +(defgeneric aka (construct supertype &key revision) + (:documentation "Returns all types if the passed construct + is of the specified type.") + (:method ((construct TopicC) (supertype TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((all-supertypes (supertypes construct :revision revision))) + (when (find supertype all-supertypes) + all-supertypes)))) \ No newline at end of file Modified: trunk/src/unit_tests/fixtures.lisp ============================================================================== --- trunk/src/unit_tests/fixtures.lisp (original) +++ trunk/src/unit_tests/fixtures.lisp Thu Nov 11 03:47:23 2010 @@ -13,6 +13,7 @@ :xml-importer :datamodel :it.bese.FiveAM + :base-tools :unittests-constants) (:import-from :constants *xtm2.0-ns*) @@ -38,7 +39,8 @@ :*XTM-MERGE2-TM* :rdf-init-db :rdf-test-db - :with-empty-db)) + :with-empty-db + :with-tm-filled-db)) (in-package :fixtures) @@ -218,4 +220,14 @@ (clean-out-db dir) (elephant:open-store (xml-importer:get-store-spec dir)) (&body) - (tear-down-test-db)) \ No newline at end of file + (tear-down-test-db)) + + +(def-fixture with-tm-filled-db (dir xtm-path) + (clean-out-db dir) + (let ((tm-id "http://www.isidor.us/unittests/testtm") + (xtm-id (full-path xtm-path))) + (xml-importer:setup-repository xtm-path dir :tm-id tm-id :xtm-id xtm-id) + (elephant:open-store (xml-importer:get-store-spec dir)) + (&body) + (tear-down-test-db))) \ No newline at end of file Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Thu Nov 11 03:47:23 2010 @@ -2629,7 +2629,7 @@ - + Modified: trunk/src/unit_tests/trivial_queries_test.lisp ============================================================================== --- trunk/src/unit_tests/trivial_queries_test.lisp (original) +++ trunk/src/unit_tests/trivial_queries_test.lisp Thu Nov 11 03:47:23 2010 @@ -10,19 +10,481 @@ (defpackage :trivial-queries-test (:use :cl :it.bese.FiveAM - :datamodel) + :datamodel + :unittests-constants + :fixtures + :constants) (:export :run-trivial-queries-tests - :trivial-queries-tests)) + :trivial-queries-tests + :test-aka + :test-isa + :test-x-by-value + :test-x-by-type + :test-invoke-on + :test-instance-of + :test-supertypes + :test-direct-instance-of + :test-direct-supertypes + :test-supertype-associations + :test-instance-of-associations + :test-associations-of + :test-roles-by-type + :test-roles-by-player + :test-filter-associations-by-type + :test-filter-associations-by-role)) (in-package :trivial-queries-test) -(def-suite trivial-queries-test +(def-suite trivial-queries-tests :description "tests various key functions of the trivial-query-test of the datamodel module") -(in-suite trivial-queries-test) +(in-suite trivial-queries-tests) + +(test test-aka + "Tests the function aka." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((region (get-item-by-id "region")) + (city (get-item-by-id "city")) + (poem (get-item-by-id "poem")) + (supertype (get-item-by-psi *supertype-psi*)) + (subtype (get-item-by-psi *subtype-psi*)) + (supertype-subtype (get-item-by-psi *supertype-subtype-psi*)) + (rev (get-revision))) + (is-true region) + (is-true city) + (is-true poem) + (is-true supertype) + (is-true subtype) + (is-true supertype-subtype) + (is-true (aka city region)) + (is-false (aka city city)) + (make-construct 'AssociationC + :start-revision rev + :instance-of supertype-subtype + :roles (list (list :start-revision rev + :player region + :instance-of subtype) + (list :start-revision rev + :player poem + :instance-of supertype))) + (is-true (aka city region)) + (is-true (aka city poem)) + (is-true (aka region poem)))))) + + +(test test-isa + "Tests the function isa." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((region (get-item-by-id "region")) + (metropolis (get-item-by-id "metropolis")) + (poem (get-item-by-id "poem")) + (frankfurt (get-item-by-id "frankfurt_am_main"))) + (is-true region) + (is-true frankfurt) + (is-true metropolis) + (is-true poem) + (is-true (isa frankfurt metropolis)) + (is-true (isa frankfurt region)))))) + + +(test test-x-by-value + "Tests the functions names-by-value, occurrences-by-value + and characteristics-by-value." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((goethe (get-item-by-id "goethe")) + (poem (get-item-by-id "poem")) + (fn "Johann Wolfgang") + (ln "von Goethe") + (ai "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe") + (as "any string")) + (let ((fun-fn (lambda(value) + (string= value fn))) + (fun-ln (lambda(value) + (string= value ln))) + (fun-ai (lambda(value) + (string= value ai))) + (fun-as (lambda(value) + (string= value as)))) + (is-true goethe) + (is-true poem) + (is-false (names-by-value goethe fun-as)) + (is-false (occurrences-by-value goethe fun-as)) + (is-false (characteristics-by-value goethe fun-as)) + (is (= (length (names-by-value goethe fun-fn)) 1)) + (is (= (length (names-by-value goethe fun-ln)) 1)) + (is (= (length (occurrences-by-value goethe fun-ai)) 1)) + (is (string= (charvalue (first (names-by-value goethe fun-fn))) + fn)) + (is (string= (charvalue (first (names-by-value goethe fun-ln))) + ln)) + (is (string= (charvalue (first (occurrences-by-value goethe fun-ai))) + ai)) + (is (= (length (characteristics-by-value goethe fun-fn)) 1)) + (is (string= + (charvalue (first (characteristics-by-value goethe fun-fn))) + fn))))))) + + +(test test-x-by-type + "Tests the functions names-by-type, occurrences-by-type + and characteristics-by-type." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((goethe (get-item-by-id "goethe")) + (first-name (get-item-by-id "first-name")) + (last-name (get-item-by-id "last-name")) + (author-info (get-item-by-id "author-info")) + (poem (get-item-by-id "poem"))) + (is-true goethe) + (is-true first-name) + (is-true last-name) + (is-true author-info) + (is-true poem) + (is-false (names-by-type goethe poem)) + (is-false (occurrences-by-type goethe poem)) + (is-false (characteristics-by-type goethe poem)) + (is (= (length (names-by-type goethe first-name)) 1)) + (is (= (length (names-by-type goethe last-name)) 1)) + (is (= (length (occurrences-by-type goethe author-info)) 1)) + (is (string= (charvalue (first (names-by-type goethe first-name))) + "Johann Wolfgang")) + (is (string= (charvalue (first (names-by-type goethe last-name))) + "von Goethe")) + (is (string= + (charvalue (first (occurrences-by-type goethe author-info))) + "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")) + (is (= (length (characteristics-by-type goethe first-name)) 1)) + (is (string= + (charvalue (first (characteristics-by-type goethe first-name))) + "Johann Wolfgang")))))) + + +(test test-invoke-on + "Tests the function invoke-on." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((frankfurt (get-item-by-id "frankfurt_am_main"))) + (is-true frankfurt) + (is (= (length (occurrences frankfurt)) 1)) + (is (= (invoke-on (first (occurrences frankfurt)) + #'(lambda(value) + (+ 1 (parse-integer value)))) + (+ 1 659021))))))) + + + +(test test-instance-of + "Tests the function instance-of." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((region (get-item-by-id "region")) + (metropolis (get-item-by-id "metropolis")) + (poem (get-item-by-id "poem")) + (frankfurt (get-item-by-id "frankfurt_am_main"))) + (is-true region) + (is-true frankfurt) + (is-true metropolis) + (is-true poem) + (is (= (length (instance-of frankfurt)) 2)) + (is-false (set-exclusive-or (instance-of frankfurt) + (list metropolis region))))))) + + +(test test-supertypes + "Tests the function supertypes." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((region (get-item-by-id "region")) + (city (get-item-by-id "city")) + (poem (get-item-by-id "poem")) + (supertype (get-item-by-psi *supertype-psi*)) + (subtype (get-item-by-psi *subtype-psi*)) + (supertype-subtype (get-item-by-psi *supertype-subtype-psi*)) + (rev (get-revision))) + (is-true region) + (is-true city) + (is-true poem) + (is-true supertype) + (is-true subtype) + (is-true supertype-subtype) + (is (= (length (supertypes city)) 1)) + (is (eql (first (supertypes city)) region)) + (is-false (supertypes region)) + (make-construct 'AssociationC + :start-revision rev + :instance-of supertype-subtype + :roles (list (list :start-revision rev + :player region + :instance-of subtype) + (list :start-revision rev + :player poem + :instance-of supertype))) + (is (= (length (supertypes city)) 2)))))) + + +(test test-direct-instance-of + "Tests the function direct-instance-of." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((region (get-item-by-id "region")) + (frankfurt (get-item-by-id "frankfurt_am_main")) + (metropolis (get-item-by-id "metropolis"))) + (is-true region) + (is-true metropolis) + (is-true frankfurt) + (is (= (length (direct-instance-of frankfurt)) 1)) + (is (eql (first (direct-instance-of frankfurt)) metropolis)) + (is-false (direct-instance-of metropolis)))))) + + +(test test-direct-supertypes + "Tests the function direct-supertypes." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((region (get-item-by-id "region")) + (city (get-item-by-id "city")) + (poem (get-item-by-id "poem")) + (supertype (get-item-by-psi *supertype-psi*)) + (subtype (get-item-by-psi *subtype-psi*)) + (supertype-subtype (get-item-by-psi *supertype-subtype-psi*)) + (rev (get-revision))) + (is-true region) + (is-true city) + (is-true poem) + (is-true supertype) + (is-true subtype) + (is-true supertype-subtype) + (is (= (length (direct-supertypes city)) 1)) + (is (eql (first (direct-supertypes city)) region)) + (is-false (direct-supertypes region)) + (make-construct 'AssociationC + :start-revision rev + :instance-of supertype-subtype + :roles (list (list :start-revision rev + :player region + :instance-of subtype) + (list :start-revision rev + :player poem + :instance-of supertype))) + (is (= (length (direct-supertypes city)) 1)))))) + + +(test test-supertype-associations + "Tests the function supertype-associations." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((region (get-item-by-id "region")) + (city (get-item-by-id "city")) + (metropolis (get-item-by-id "metropolis")) + (assocs (get-all-associations)) + (supertype (get-item-by-psi *supertype-psi*)) + (subtype (get-item-by-psi *subtype-psi*)) + (supertype-subtype (get-item-by-psi *supertype-subtype-psi*))) + (is-true region) + (is-true city) + (is-true metropolis) + (is-true supertype) + (is-true subtype) + (is-true supertype-subtype) + (let ((assoc-city + (find-if + #'(lambda(assoc) + (and (eql (instance-of assoc) supertype-subtype) + (find-if #'(lambda(role) + (and (eql (player role) city) + (eql (instance-of role) subtype))) + (roles assoc)) + (find-if #'(lambda(role) + (and (eql (player role) region) + (eql (instance-of role) supertype))) + (roles assoc)))) + assocs)) + (assoc-metropolis + (find-if + #'(lambda(assoc) + (and (eql (instance-of assoc) supertype-subtype) + (find-if #'(lambda(role) + (and (eql (player role) metropolis) + (eql (instance-of role) subtype))) + (roles assoc)) + (find-if #'(lambda(role) + (and (eql (player role) region) + (eql (instance-of role) supertype))) + (roles assoc)))) + assocs))) + (is-true assoc-city) + (is-true assoc-metropolis) + (is (= (length (supertype-associations city)) 1)) + (is (= (length (supertype-associations metropolis)) 1)) + (is (eql (first (supertype-associations city)) assoc-city)) + (is (eql (first (supertype-associations metropolis)) assoc-metropolis)) + (is-false (supertype-associations region))))))) + + +(test test-instance-of-associations + "Tests the function instance-of-associations." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((goethe (get-item-by-id "goethe")) + (instance (get-item-by-psi *instance-psi*)) + (type (get-item-by-psi *type-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (author (get-item-by-id "author"))) + (is-true goethe) + (is-true instance) + (is-true type) + (is-true type-instance) + (is-true author) + (is (= (length (instance-of-associations goethe)) 1)) + (is (eql type-instance + (instance-of (first (instance-of-associations goethe))))) + (is-true (filter-associations-by-role (instance-of-associations goethe) + instance goethe)) + (is-true (filter-associations-by-role (instance-of-associations goethe) + type author)) + (is-true (filter-associations-by-type (instance-of-associations goethe) + type-instance)))))) + + +(test test-associations-of + "Tests the function associations-of." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((goethe (get-item-by-id "goethe")) + (writer (get-item-by-id "writer")) + (written-by (get-item-by-id "written-by")) + (written (get-item-by-id "written")) + (erlkoenig (get-item-by-id "erlkoenig")) + (instance (get-item-by-psi *instance-psi*)) + (poem (get-item-by-id "poem"))) + (is-true goethe) + (is-true writer) + (is-true written-by) + (is-true written) + (is-true erlkoenig) + (is-true instance) + (is-true poem) + (is (= (length (associations-of goethe nil nil nil nil)) 4)) + (is (= (length (associations-of goethe writer nil nil nil)) 3)) + (is (= (length (associations-of goethe writer written-by nil nil)) 2)) + (is (= (length (associations-of goethe writer written-by written nil)) 2)) + (is (= (length (associations-of goethe writer written-by written erlkoenig)) 1)) + (is-false (associations-of goethe writer written-by written instance)) + (is-false (associations-of goethe writer written-by instance erlkoenig)) + (is (= (length (associations-of goethe instance nil nil nil)) 1)) + (is-false (associations-of goethe writer written-by written erlkoenig + :other-role-player-is-type t)) + (is (= (length (associations-of goethe writer written-by written poem + :other-role-player-is-type t)) 2)))))) + + +(test test-roles-by-type + "Tests the function roles-by-type bound to TopicC and AssociationC." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((goethe (get-item-by-id "goethe")) + (writer (get-item-by-id "writer")) + (written (get-item-by-id "written")) + (instance (get-item-by-psi *instance-psi*)) + (assoc (get-item-by-item-identifier "written-by-erlkoenig-goethe"))) + (is-true goethe) + (is-true writer) + (is-true written) + (is-true instance) + (is-true assoc) + (is (= (length (roles-by-type goethe writer)) 3)) + (is (= (length (roles-by-type goethe nil)) 4)) + (is (= (length (roles-by-type goethe instance)) 1)) + (is-false (roles-by-type goethe written)) + (is (= (length (roles-by-type assoc writer)) 1)) + (is (eql writer (instance-of (first (roles-by-type assoc writer))))) + (is (= (length (roles-by-type assoc nil)) 2)))))) + + +(test test-roles-by-player + "Tests the function roles-by-player." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((goethe (get-item-by-id "goethe")) + (writer (get-item-by-id "writer")) + (written (get-item-by-id "written")) + (instance (get-item-by-psi *instance-psi*)) + (assoc (get-item-by-item-identifier "written-by-erlkoenig-goethe")) + (author (get-item-by-id "author"))) + (is-true goethe) + (is-true author) + (is-true writer) + (is-true written) + (is-true instance) + (is-true assoc) + (is (= (length (roles-by-player assoc goethe)) 1)) + (is (eql goethe (player (first (roles-by-player assoc goethe))))) + (is (= (length (roles-by-player assoc written)) 0)) + (is (= (length (roles-by-player assoc nil)) 2)) + (is (= (length (roles-by-player assoc author :role-player-is-type t)) + 1)) + (is-false (roles-by-player assoc goethe :role-player-is-type t)) + (is (eql goethe (player (first (roles-by-player + assoc author + :role-player-is-type t))))))))) + + +(test test-filter-associations-by-type + "Tests the function roles-by-player." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((written-by (get-item-by-id "written-by")) + (born-in (get-item-by-id "born-in")) + (assocs (get-all-associations))) + (is-true written-by) + (is-true assocs) + (is-true born-in) + (is (= (length (filter-associations-by-type assocs written-by)) 4)) + (is (> (length (filter-associations-by-type assocs nil)) (+ 4 2))) + (is (= (length (filter-associations-by-type assocs born-in)) 2)))))) + + +(test test-filter-associations-by-role + "Tests the function roles-by-player." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let ((written-by (get-item-by-id "written-by")) + (born-in (get-item-by-id "born-in")) + (written (get-item-by-id "written")) + (writer (get-item-by-id "writer")) + (place (get-item-by-id "place")) + (goethe (get-item-by-id "goethe")) + (frankfurt (get-item-by-id "frankfurt_am_main")) + (assocs (get-all-associations)) + (author (get-item-by-id "author"))) + (is-true written-by) + (is-true assocs) + (is-true born-in) + (is-true author) + (is-true written) + (is-true writer) + (is-true place) + (is-true frankfurt) + (is (= (length (filter-associations-by-role assocs place frankfurt)) 1)) + (is (= (length (filter-associations-by-role assocs written nil)) 4)) + (is (= (length (filter-associations-by-role assocs written goethe)) 2)) + (is (= (length (filter-associations-by-role assocs writer nil)) 6)) + (is (= (length (filter-associations-by-role assocs nil goethe)) 4)) + (is (> (length (filter-associations-by-role assocs nil nil)) (+ 4 3))) + (is-false (filter-associations-by-role assocs writer goethe + :role-player-is-type t)) + (is (= (length (filter-associations-by-role assocs writer author + :role-player-is-type t)) + 6)))))) + + + (defun run-trivial-queries-tests () Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Thu Nov 11 03:47:23 2010 @@ -29,6 +29,7 @@ :*t100.xtm* :*atom_test.xtm* :*atom-conf.lisp* + :*poems.xtm* :*poems_light.rdf* :*poems_light.xtm* :*poems_light.xtm.txt* @@ -100,6 +101,10 @@ (asdf:component-pathname (asdf:find-component *unit-tests-component* "atom-conf"))) +(defparameter *poems.xtm* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "poems.xtm"))) + (defparameter *poems_light.rdf* (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light.rdf"))) From lgiessmann at common-lisp.net Fri Nov 12 21:57:52 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 12 Nov 2010 16:57:52 -0500 Subject: [isidorus-cvs] r338 - in trunk/src: . model unit_tests Message-ID: Author: lgiessmann Date: Fri Nov 12 16:57:51 2010 New Revision: 338 Log: added the new textgrid-TMCL as XTM 2.0 file Added: trunk/src/unit_tests/textgrid.xtm trunk/src/unit_tests/textgrid_old.xtm Modified: trunk/src/isidorus.asd trunk/src/model/trivial-queries.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Fri Nov 12 16:57:51 2010 @@ -107,7 +107,9 @@ "json" "threading")) (:module "unit_tests" - :components ((:static-file "dangling_topicref.xtm") + :components ((:static-file "textgrid.xtm") + (:static-file "textgrid_old.xtm") + (:static-file "dangling_topicref.xtm") (:static-file "inconsistent.xtm") (:static-file "notificationbase.xtm") (:static-file "notification_merge1.xtm") Modified: trunk/src/model/trivial-queries.lisp ============================================================================== --- trunk/src/model/trivial-queries.lisp (original) +++ trunk/src/model/trivial-queries.lisp Fri Nov 12 16:57:51 2010 @@ -338,4 +338,4 @@ (declare (integer revision)) (let ((all-supertypes (supertypes construct :revision revision))) (when (find supertype all-supertypes) - all-supertypes)))) \ No newline at end of file + all-supertypes)))) Added: trunk/src/unit_tests/textgrid.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/textgrid.xtm Fri Nov 12 16:57:51 2010 @@ -0,0 +1,4826 @@ +? + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + ^http://textgrid.org/serviceregistry/service/.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + ^http://textgrid.org/serviceregistry/hash/.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + ^http://textgrid.org/serviceregistry/parameter/.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + ^http://textgrid.org/serviceregistry/parameter-config/.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 0 + + + + + + .* + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + .* + + + + + + + + + + + + + + http://www.w3.org/2001/XMLSchema#string + + + + + + + + + + + + + http://www.w3.org/2001/XMLSchema#anyUri + + + + + + + + + + + + + http://www.w3.org/2001/XMLSchema#boolean + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + (true)|(false) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + (true)|(false) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + (true)|(false) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + (true)|(false) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + (true)|(false) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + (false)|(true) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + (false)|(true) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + .+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file Added: trunk/src/unit_tests/textgrid_old.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/textgrid_old.xtm Fri Nov 12 16:57:51 2010 @@ -0,0 +1,3282 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^http://textgrid.org/serviceregistry/.+/.+$ + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^http://textgrid.org/serviceregistry/url/.+$ + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^http://textgrid.org/serviceregistry/parameter/.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 0 + + + + ^.*$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 1 + + + + .* + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + http://www.w3.org/2001/XMLSchema#string + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + http://www.w3.org/2001/XMLSchema#anyUri + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 1 + + + + ^.*$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + ^.+$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + 1 + + + + .* + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + 1 + + + + + + ^(true)|(TRUE)|(false)|(FALSE)$ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +http://www.w3.org/2001/XMLSchema#boolean + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + schema-name + + + + production + + + + schema + + + + + + + + + www.textgrid.info/schemas/textgrid-metadata_2008-07-24.xsd + + + + + + + + + + + + + + + + + + + + + + ns-name + + + + production + + + + ns + + + + + + + + + http://textgrid.info/namespaces/metadata/core/2008-07-24 + + + + + + + + + + + + + + + + + + + + + + workflow-name + + + + production + + + + workflow + + + + + + + + + http://ingrid.sub.uni-goettingen.de/gwes/services/GWES + + + + + + + + + + + + + + + + + + + + + + authz-name + + + + production + + + + authz + + + + + + + + + https://textgridlab.org/WebAuthN/WebAuthN.php + + + + + + + + + authZinstance + + + + textgridlab.org + + + + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + tgauth-name + + + + production + + + + tgauth + + + + + + + + + https://textgridlab.org/tgauth/rbacSoap/tgextra.php + + + + + + + + + + + + + + + + + + + + + + tgsearch-name + + + + production + + + + tgsearch + + + + + + + + + https://textgridlab.org/axis2/services/Metadata + + + + + + + + + + + + + + + + + + + + + + tgcrud-name + + + + production + + + + tgcrud + + + + + + + + + https://textgridlab.org/axis2/services/TGCrudService + + + + + + + + + + + + + + + + + + + + + + logservice-name + + + + production + + + + logservice + + + + + + + + + https://textgridlab.org/axis2/services/textlog + + + + + + + + + + + + + + + + + + + + + + exist-name + + + + production + + + + exist + + + + + + + + + https://textgridlab.org/exist/services/Query + + + + + + + + + + + + + + + + + + + + + + rdf-repository-name + + + + production + + + + rdf-repository + + + + + + + + + https://textgridlab.org/openrdf-sesame/repositories/textgrid + + + + + + + + + + + + + + + + + + + + + + last-api-change-name + + + + production + + + + last-api-change + + + + + + + + + 2009-01-21 + + + + + + + + + + + + + + + + + + + + + + webpublish-name + + + + production + + + + webpublish + + + + + + + + + http://textgrid-ws2.gwdg.de/teiPublisher/2/publish + + + + + + + + + + + + + + + + + + + + + + + + schema-name + + + + testing + + + + schema + + + + + + + + + www.textgrid.info/schemas/textgrid-metadata_2008-07-24.xsd + + + + + + + + + + + + + + + + + + + + + + ns-name + + + + testing + + + + ns + + + + + + + + + http://textgrid.info/namespaces/metadata/core/2008-07-24 + + + + + + + + + + + + + + + + + + + + + + workflow-name + + + + testing + + + + workflow + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8083/gwes/services/GWES + + + + + + + + + + + + + + + + + + + + + + authz-name + + + + testing + + + + authz + + + + + + + + + https://textgridlab.org/WebAuthN/WebAuthN.php + + + + + + + + + authZinstance + + + + ingrid-8081 + + + + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + tgauth-name + + + + testing + + + + tgauth + + + + + + + + + http://ingrid.sub.uni-goettingen.de/rbac-8081/tgextra.php + + + + + + + + + + + + + + + + + + + + + + tgsearch-name + + + + testing + + + + tgsearch + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8081/axis2/services/Metadata + + + + + + + + + + + + + + + + + + + + + + tgcrud-name + + + + testing + + + + tgcrud + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8081/axis2/services/TGCrudService + + + + + + + + + + + + + + + + + + + + + + logservice-name + + + + testing + + + + logservice + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8081/axis2/services/textlog + + + + + + + + + + + + + + + + + + + + + + exist-name + + + + testing + + + + exist + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8081/exist/services/Query + + + + + + + + + + + + + + + + + + + + + + rdf-repository-name + + + + testing + + + + rdf-repository + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8082/openrdf-sesame/repositories/textgrid + + + + + + + + + + + + + + + + + + + + + + last-api-change-name + + + + testing + + + + last-api-change + + + + + + + + + 2009-01-21 + + + + + + + + + + + + + + + + + + + + + + webpublish-name + + + + testing + + + + webpublish + + + + + + + + + http://textgrid-ws2.gwdg.de/teiPublisher/0/publish + + + + + + + + + + + + + + + + + + + + + + + + schema-name + + + + development + + + + schema + + + + + + + + + www.textgrid.info/schemas/textgrid-metadata_2008-07-24.xsd + + + + + + + + + + + + + + + + + + + + + + ns-name + + + + development + + + + ns + + + + + + + + + http://textgrid.info/namespaces/metadata/core/2008-07-24 + + + + + + + + + + + + + + + + + + + + + + workflow-name + + + + development + + + + workflow + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8083/gwes/services/GWES + + + + + + + + + + + + + + + + + + + + + + authz-name + + + + development + + + + authz + + + + + + + + + https://textgridlab.org/Portal/WebAuthN.php + + + + + + + + + authZinstance + + + + ingrid-8082 + + + + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + tgauth-name + + + + development + + + + tgauth + + + + + + + + + http://ingrid.sub.uni-goettingen.de/rbac-8082/tgextra.php + + + + + + + + + + + + + + + + + + + + + + tgsearch-name + + + + development + + + + tgsearch + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8082/axis2/services/Metadata + + + + + + + + + + + + + + + + + + + + + + tgcrud-name + + + + development + + + + tgcrud + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8082/axis2/services/TGCrudService + + + + + + + + + + + + + + + + + + + + + + logservice-name + + + + development + + + + logservice + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8082/axis2/services/textlog + + + + + + + + + + + + + + + + + + + + + + exist-name + + + + development + + + + exist + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8082/exist/services/Query + + + + + + + + + + + + + + + + + + + + + + rdf-repository-name + + + + development + + + + rdf-repository + + + + + + + + + http://ingrid.sub.uni-goettingen.de:8082/openrdf-sesame/repositories/textgrid + + + + + + + + + + + + + + + + + + + + + + last-api-change-name + + + + development + + + + last-api-change + + + + + + + + + 2009-01-21 + + + + + + + + + + + + + + + + + + + + + + webpublish-name + + + + development + + + + webpublish + + + + + + + + + http://textgrid-ws2.gwdg.de/teiPublisher/1/publish + + + + + + + + + + + + + + + + + From lgiessmann at common-lisp.net Fri Nov 12 23:23:19 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 12 Nov 2010 18:23:19 -0500 Subject: [isidorus-cvs] r339 - tags/textgrid-service/src/rest_interface trunk/src trunk/src/rest_interface Message-ID: Author: lgiessmann Date: Fri Nov 12 18:23:19 2010 New Revision: 339 Log: fixed ticket #93 => implemented a hunchentoot post handler that imports the received data via the xtm2.0 importer Modified: tags/textgrid-service/src/rest_interface/rest-interface.lisp tags/textgrid-service/src/rest_interface/set-up-json-interface.lisp trunk/src/isidorus.asd trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: tags/textgrid-service/src/rest_interface/rest-interface.lisp ============================================================================== --- tags/textgrid-service/src/rest_interface/rest-interface.lisp (original) +++ tags/textgrid-service/src/rest_interface/rest-interface.lisp Fri Nov 12 18:23:19 2010 @@ -41,7 +41,8 @@ :*ajax-user-interface-file-path* :*ajax-javascript-directory-path* :*ajax-javascript-url-prefix* - :*mark-as-deleted-url*)) + :*mark-as-deleted-url* + :*xtm-commit-prefix*)) (in-package :rest-interface) Modified: tags/textgrid-service/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- tags/textgrid-service/src/rest_interface/set-up-json-interface.lisp (original) +++ tags/textgrid-service/src/rest_interface/set-up-json-interface.lisp Fri Nov 12 18:23:19 2010 @@ -25,8 +25,9 @@ (defparameter *ajax-user-interface-css-directory-path* "ajax/css") ;the directory contains the css files (defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") ;the file path to the HTML file implements the user interface (defparameter *ajax-javascript-directory-path* "ajax/javascripts") ;the directory which contains all necessary javascript files -(defparameter *ajax-javascript-url-prefix* "/javascripts") ; the url prefix of all javascript files -(defparameter *mark-as-deleted-url* "/mark-as-deleted") ; the url suffix that calls the mark-as-deleted handler +(defparameter *ajax-javascript-url-prefix* "/javascripts") ;the url prefix of all javascript files +(defparameter *mark-as-deleted-url* "/mark-as-deleted") ;the url suffix that calls the mark-as-deleted handler +(defparameter *xtm-commit-prefix* "/import/xtm/2.0/(.+)$") ;the url to commit a TM-fragment in XTM 2.0 format, the regular expression represents the topic map id (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*) (get-rdf-prefix *get-rdf-prefix*) @@ -45,7 +46,8 @@ (ajax-user-interface-css-directory-path *ajax-user-interface-css-directory-path*) (ajax-javascripts-directory-path *ajax-javascript-directory-path*) (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) - (mark-as-deleted-url *mark-as-deleted-url*)) + (mark-as-deleted-url *mark-as-deleted-url*) + (xtm-commit-prefix *xtm-commit-prefix*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -112,6 +114,9 @@ (create-regex-dispatcher json-commit-url #'json-commit) hunchentoot:*dispatch-table*) (push + (create-regex-dispatcher xtm-commit-prefix #'xtm-import-handler) + hunchentoot:*dispatch-table*) + (push (create-regex-dispatcher json-get-summary-url #'return-topic-summaries) hunchentoot:*dispatch-table*) (push @@ -378,6 +383,29 @@ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))) +(defun xtm-import-handler (&optional tm-id) + "Imports the received data as XTM 2.0 topic map." + (assert tm-id) + (handler-case + (if (eql (hunchentoot:request-method*) :POST) + (let ((external-format (flexi-streams:make-external-format + :UTF-8 :eol-style :LF))) + (let ((xml-data (hunchentoot:raw-post-data + :external-format external-format + :force-text t))) + (let ((xml-dom + (dom:document-element + (cxml:parse xml-data (cxml-dom:make-dom-builder))))) + (xml-importer:importer xml-dom :tm-id tm-id + :xtm-id (xml-importer::get-uuid)) + (format nil "")))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)) + (condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err))))) + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; ============================================================================= Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Fri Nov 12 18:23:19 2010 @@ -101,8 +101,8 @@ :depends-on ("rest-interface")) (:file "read" :depends-on ("rest-interface"))) - :depends-on ("model" - "atom" + :depends-on ("model" + "atom" "xml" "json" "threading")) Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Fri Nov 12 18:23:19 2010 @@ -10,6 +10,7 @@ (defpackage :rest-interface (:nicknames :rest) (:use :cl :hunchentoot + :cxml :constants :atom :datamodel @@ -40,7 +41,8 @@ :*ajax-user-interface-url* :*ajax-user-interface-file-path* :*ajax-javascript-directory-path* - :*ajax-javascript-url-prefix*)) + :*ajax-javascript-url-prefix* + :*xtm-commit-prefix*)) (in-package :rest-interface) 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 Nov 12 18:23:19 2010 @@ -20,6 +20,9 @@ (defparameter *get-rdf-prefix* "/json/get/rdf/(.+)$") ;the url to commit a json fragment by "put" or "post" (defparameter *json-commit-url* "/json/commit/?$") +;the url to commit a TM-fragment in XTM 2.0 format, the regular +;expression represents the topic map id +(defparameter *xtm-commit-prefix* "/import/xtm/2.0/(.+)$") ;the url to get all topic psis of isidorus -> localhost:8000/json/psis (defparameter *json-get-all-psis* "/json/psis/?$") ;the url to get a summary of all topic stored in isidorus; you have to set the @@ -75,7 +78,8 @@ (ajax-javascripts-directory-path *ajax-javascript-directory-path*) (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) (mark-as-deleted-url *mark-as-deleted-url*) - (latest-revision-url *latest-revision-url*)) + (latest-revision-url *latest-revision-url*) + (xtm-commit-prefix *xtm-commit-prefix*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -153,6 +157,9 @@ (create-regex-dispatcher mark-as-deleted-url #'mark-as-deleted-handler) hunchentoot:*dispatch-table*) (push + (create-regex-dispatcher xtm-commit-prefix #'xtm-import-handler) + hunchentoot:*dispatch-table*) + (push (create-regex-dispatcher latest-revision-url #'return-latest-revision) hunchentoot:*dispatch-table*)) @@ -450,9 +457,31 @@ (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") (format nil "Condition: \"~a\"" err))))) - +(defun xtm-import-handler (&optional tm-id) + "Imports the received data as XTM 2.0 topic map." + (assert tm-id) + (handler-case + (if (eql (hunchentoot:request-method*) :POST) + (let ((external-format (flexi-streams:make-external-format + :UTF-8 :eol-style :LF))) + (let ((xml-data (hunchentoot:raw-post-data + :external-format external-format + :force-text t))) + (let ((xml-dom + (dom:document-element + (cxml:parse xml-data (cxml-dom:make-dom-builder))))) + (xml-importer:importer xml-dom :tm-id tm-id + :xtm-id (xml-importer::get-uuid)) + (format nil "")))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)) + (condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err))))) + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; ============================================================================= From lgiessmann at common-lisp.net Wed Nov 17 21:41:59 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 17 Nov 2010 16:41:59 -0500 Subject: [isidorus-cvs] r340 - in trunk/src: . TM-SPARQL base-tools model xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Wed Nov 17 16:41:59 2010 New Revision: 340 Log: added a SPARQL-Query class with several accessor-methods. This class contains the actual query-string, some query-attributes and the result objects; started to implement a SPARQL-parser => currently the PREFIX parts can be processed; added some functions to base-tools Added: trunk/src/TM-SPARQL/sparql_parser.lisp - copied, changed from r336, /trunk/src/TM-SPARQL/sparql_tokenizer.lisp Removed: trunk/src/TM-SPARQL/sparql_tokenizer.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/base-tools/base-tools.lisp trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/model/exceptions.lisp trunk/src/xml/rdf/exporter.lisp trunk/src/xml/xtm/tools.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Nov 17 16:41:59 2010 @@ -7,4 +7,60 @@ ;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- +(defpackage :TM-SPARQL + (:use :cl :datamodel :base-tools :exceptions) + (:export :SPARQL-Query)) + + (in-package :TM-SPARQL) + +(defvar *empty-label* "_empty_label_symbol") + + +(defclass SPARQL-Query () + ((original-query :initarg :original-query + :reader original-query + :type String + :initform (error + (make-condition + 'missing-query-string-error + :message "From TM-Query(): original-query must be set")) + :documentation "Containst the original received querry as string") + (prefix-list :initarg :prefix-list + :reader prefix-list + :type List + :documentation "A list of the form + ((:label 'id' :value 'prefix'))") + (variables :initarg :variables + :accessor :variables + :type List + :documentation "A list of the form ((:variable var-symbol + :value value-object)), that contains tuples + for each variable and its result.") + (select-statements :initarg :select-statements + :accessor select-statements + :type List + :documentation "A list of the form ((:statement 'statement' + :value value-object))"))) + + +(defgeneric add-prefix (construct prefix-label prefix-value) + (:documentation "Adds the new prefix tuple to the list of all existing. + If there already exists a tuple with the same label + the label's value will be overwritten by the new value.") + (:method ((construct SPARQL-Query) (prefix-label Symbol) (prefix-value String)) + (let ((existing-tuple + (find-if #'(lambda(x) + (eql (getf x :label) prefix-label)) + (prefix-list construct)))) + (if existing-tuple + (setf (getf existing-tuple :value) prefix-value) + (push (list :label prefix-label :value prefix-value) + (slot-value construct 'prefix-list)))))) + + + +(defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) + (declare (ignorable args)) + (parser-start construct) + construct) Copied: trunk/src/TM-SPARQL/sparql_parser.lisp (from r336, /trunk/src/TM-SPARQL/sparql_tokenizer.lisp) ============================================================================== --- /trunk/src/TM-SPARQL/sparql_tokenizer.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Wed Nov 17 16:41:59 2010 @@ -7,8 +7,113 @@ ;;+ trunk/docs/LGPL-LICENSE.txt. ;;+----------------------------------------------------------------------------- -(defpackage :TM-SPARQL - (:use :cl :datamodel)) +(in-package :TM-SPARQL) +(defun make-sparql-parser-condition(rest-of-query entire-query expected) + "Creates a spqrql-parser-error object." + (declare (String rest-of-query entire-query expected)) + (let ((message + (format nil "The query:~%~a bad token on position ~a. Expected: ~a" + entire-query (- (length entire-query) + (length rest-of-query)) + expected))) + (make-condition 'sparql-parser-error :message message))) -(in-package :TM-SPARQL) + + +(defgeneric parser-start(construct query-string) + (:documentation "The entry point of the SPARQL-parser.") + (:method ((construct SPARQL-Query) (query-string String)) + (let ((trimmed-query-string (trim-whitespace-left query-string))) + (cond ((string-starts-with trimmed-query-string "SELECT") + (parse-prefixes construct + (string-after trimmed-query-string "SELECT"))) + ((string-starts-with trimmed-query-string "PREFIX") + nil) ;TODO: implement + ((string-starts-with trimmed-query-string "BASE") + nil) ;TODO: implement + (t + (error (make-sparql-parser-condition + trimmed-query-string (original-query construct) + "SELECT, PREFIX or BASE"))))))) + + +(defgeneric parse-prefixes (construct query-string) + (:documentation "Sets the correponding prefix-tuples in the passed object.") + (:method ((construct SPARQL-Query) (query-string String)) + (let ((trimmed-string (trim-whitespace-left query-string))) + (if (string-starts-with trimmed-string ":") + (let ((results + (parse-bracket-value (subseq trimmed-string 1) construct))) + (add-prefix construct *empty-label* (getf results :value)) + (parser-start construct (getf results :query-string))) + (let* ((label-name + (trim-whitespace-right (string-until trimmed-string ":"))) + (next-query-str + (trim-whitespace-left (string-after trimmed-string ":"))) + (results (parse-bracket-value next-query-str construct))) + (add-prefix construct label-name (getf results :value)) + (parser-start construct (getf results :query-string))))))) + + +(defun parse-bracket-value(query-string query-object &key (open "<") (close ">")) + "A helper function that checks the value of a statement within + two brackets, i.e. . A list of the + form (:query-string string :value string) is returned." + (declare (String query-string open close) + (SPARQL-Query query-object)) + (let ((trimmed-string (trim-whitespace-left query-string))) + (if (and (string-starts-with trimmed-string open) + (> (length (string-after trimmed-string close)) 0)) + (let* ((pref-url + (string-until (string-after trimmed-string open) close)) + (next-query-str + (string-after pref-url close))) + (unless next-query-str + (error (make-sparql-parser-condition + trimmed-string (original-query query-object) + close))) + (list :query-string next-query-str + :value pref-url)) + (error (make-sparql-parser-condition + trimmed-string (original-query query-object) + open))))) + + + +;((PREFIX bounding: )|(PREFIX : )* +;(BASE )*)* +;SELECT ?varName+ +;WHERE { +;(({?subjectOrVarName predicateOrVarName objectOrVarName}?)* +;({?FILTER (filterExpression)}?)* +;(BASE )*)* +;} +;Grouping +;{} +;Base +;BASE +;? +; +;-> uri/book +;Literals +;(?anyCharacter*?)|(?anyCharacter*?)((anyUri)|(@languageTag)){0,1} +; +;Variables +;($anyChar*)|(?anyChar*) +;?var = $var +;Predicate object-lists +;?x foaf:name ?name ; +;foaf:mbox ?mbox . +;This is the same as writing the triple patterns: +;?x foaf:name ?name . +;?x foaf:mbox ?mbox . +;rdf:type +;rdf:type = a +;Empty Graph Pattern +;The group pattern: +;{ } +;matches any graph (including the empty graph) with one solution that does not bind any variables. For example: +;SELECT ?x +;WHERE {} +;matches with one solution in which variable x is not bound." \ No newline at end of file Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Wed Nov 17 16:41:59 2010 @@ -13,7 +13,14 @@ (:export :push-string :when-do :remove-null - :full-path)) + :full-path + :trim-whitespace-left + :trim-whitespace-right + :trim-whitespace + :string-starts-with + :string-starts-with-char + :string-until + :string-after)) (in-package :base-tools) @@ -52,4 +59,53 @@ (full-path-string "")) (dolist (segment segments) (push-string segment full-path-string)) - (concatenate 'string full-path-string "/" (pathname-name pathname)))) \ No newline at end of file + (concatenate 'string full-path-string "/" (pathname-name pathname)))) + + +(defun trim-whitespace-left (value) + "Uses string-left-trim with a predefined character-list." + (declare (String value)) + (string-left-trim '(#\Space #\Tab #\Newline) value)) + + +(defun trim-whitespace-right (value) + "Uses string-right-trim with a predefined character-list." + (declare (String value)) + (string-right-trim '(#\Space #\Tab #\Newline) value)) + + +(defun trim-whitespace (value) + "Uses string-trim with a predefined character-list." + (declare (String value)) + (string-trim '(#\Space #\Tab #\Newline) value)) + + +(defun string-starts-with (str prefix) + "Checks if string str starts with a given prefix." + (declare (string str prefix)) + (string= str prefix :start1 0 :end1 + (min (length prefix) + (length str)))) + + +(defun string-starts-with-char (begin str) + (equal (char str 0) begin)) + + +(defun string-until (str anchor) + "Returns a substring until the position of the passed anchor." + (declare (String str anchor)) + (let ((pos (search anchor str))) + (if pos + (subseq str 0 pos) + str))) + + +(defun string-after (str prefix) + "Returns the substring after the found prefix. + If there is no substring equal to prefix nil is returned." + (declare (String str prefix)) + (let ((pos (search prefix str))) + (if pos + (subseq str (+ pos (length prefix))) + nil))) \ No newline at end of file Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Nov 17 16:41:59 2010 @@ -41,9 +41,9 @@ :depends-on ("exceptions"))) :depends-on ("constants" "base-tools")) (:module "TM-SPARQL" - :components ((:file "sparql" - :depends-on ("sparql_tokenizer")) - (:file "sparql_tokenizer")) + :components ((:file "sparql") + (:file "sparql_parser" + :depends-on ("sparql"))) :depends-on ("constants" "base-tools" "model")) (:module "xml" :components ((:module "xtm" Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Wed Nov 17 16:41:59 2010 @@ -135,7 +135,6 @@ :list-instanceOf :list-super-types :in-topicmap - :string-starts-with :get-fragments :get-fragment :get-all-revisions @@ -884,14 +883,6 @@ (slot-value construct (find-symbol "OID" 'elephant))) -(defun string-starts-with (str prefix) - "Checks if string str starts with a given prefix." - (declare (string str prefix)) - (string= str prefix :start1 0 :end1 - (min (length prefix) - (length str)))) - - ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric mark-as-deleted (construct &key source-locator revision) (:documentation "Mark a construct as deleted if it comes from the source Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Wed Nov 17 16:41:59 2010 @@ -17,10 +17,25 @@ :not-mergable-error :missing-argument-error :tm-reference-error - :bad-type-error)) + :bad-type-error + :missing-query-string-error + :sparql-parser-error)) (in-package :exceptions) + +(define-condition missing-query-string-error(error) + ((message + :initarg :message + :accessor message))) + + +(define-condition sparql-parser-error(error) + ((message + :initarg :message + :accessor message))) + + (define-condition inconsistent-file-error(error) ((message :initarg :message Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Wed Nov 17 16:41:59 2010 @@ -8,7 +8,8 @@ ;;+----------------------------------------------------------------------------- (defpackage :rdf-exporter - (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel) + (:use :cl :cxml :elephant :datamodel :isidorus-threading + :datamodel :base-tools) (:import-from :constants *rdf-ns* *rdfs-ns* Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Wed Nov 17 16:41:59 2010 @@ -275,15 +275,11 @@ (defun xpath-single-child-elem-by-qname (elem namespace-uri local-name) - "Returns some child of elem that has qname (namespace-uri local-name) or -nil if no such child exists." + "Returns some child of elem that has qname (namespace-uri local-name) + or nil if no such child exists." (declare (dom:element elem)) - (find-if (lambda (el) (has-qname el namespace-uri local-name)) (dom:child-nodes elem)) - ) - - -(defun string-starts-with (begin str) - (equal (char str 0) begin)) + (find-if (lambda (el) (has-qname el namespace-uri local-name)) + (dom:child-nodes elem))) (defun xpath-select-location-path (elem list-of-qnames) @@ -297,7 +293,7 @@ (cond (list-of-qnames (cond - ((string-starts-with #\@ local-name) + ((string-starts-with-char #\@ local-name) (list (dom:get-attribute-node-ns elem namespace-uri (string-left-trim "@" local-name)))) (t (apply #'append From lgiessmann at common-lisp.net Thu Nov 18 20:04:16 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 18 Nov 2010 15:04:16 -0500 Subject: [isidorus-cvs] r341 - in trunk/src: TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Thu Nov 18 15:04:16 2010 New Revision: 341 Log: fixed several bugs in the processing of PREFIX-statements Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Thu Nov 18 15:04:16 2010 @@ -18,7 +18,7 @@ (defclass SPARQL-Query () - ((original-query :initarg :original-query + ((original-query :initarg :query :reader original-query :type String :initform (error @@ -29,6 +29,7 @@ (prefix-list :initarg :prefix-list :reader prefix-list :type List + :initform nil :documentation "A list of the form ((:label 'id' :value 'prefix'))") (variables :initarg :variables @@ -48,10 +49,10 @@ (:documentation "Adds the new prefix tuple to the list of all existing. If there already exists a tuple with the same label the label's value will be overwritten by the new value.") - (:method ((construct SPARQL-Query) (prefix-label Symbol) (prefix-value String)) + (:method ((construct SPARQL-Query) (prefix-label String) (prefix-value String)) (let ((existing-tuple (find-if #'(lambda(x) - (eql (getf x :label) prefix-label)) + (string= (getf x :label) prefix-label)) (prefix-list construct)))) (if existing-tuple (setf (getf existing-tuple :value) prefix-value) @@ -62,5 +63,5 @@ (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) - (parser-start construct) + (parser-start construct (original-query construct)) construct) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Thu Nov 18 15:04:16 2010 @@ -26,10 +26,10 @@ (:method ((construct SPARQL-Query) (query-string String)) (let ((trimmed-query-string (trim-whitespace-left query-string))) (cond ((string-starts-with trimmed-query-string "SELECT") - (parse-prefixes construct - (string-after trimmed-query-string "SELECT"))) + nil) ;;TODO: implement ((string-starts-with trimmed-query-string "PREFIX") - nil) ;TODO: implement + (parse-prefixes construct + (string-after trimmed-query-string "PREFIX"))) ((string-starts-with trimmed-query-string "BASE") nil) ;TODO: implement (t @@ -52,6 +52,9 @@ (next-query-str (trim-whitespace-left (string-after trimmed-string ":"))) (results (parse-bracket-value next-query-str construct))) + (when (string= label-name trimmed-string) + (error (make-sparql-parser-condition + trimmed-string (original-query construct) ":"))) (add-prefix construct label-name (getf results :value)) (parser-start construct (getf results :query-string))))))) @@ -63,12 +66,9 @@ (declare (String query-string open close) (SPARQL-Query query-object)) (let ((trimmed-string (trim-whitespace-left query-string))) - (if (and (string-starts-with trimmed-string open) - (> (length (string-after trimmed-string close)) 0)) - (let* ((pref-url - (string-until (string-after trimmed-string open) close)) - (next-query-str - (string-after pref-url close))) + (if (string-starts-with trimmed-string open) + (let* ((pref-url (string-until (string-after trimmed-string open) close)) + (next-query-str (string-after trimmed-string close))) (unless next-query-str (error (make-sparql-parser-condition trimmed-string (original-query query-object) @@ -77,7 +77,7 @@ :value pref-url)) (error (make-sparql-parser-condition trimmed-string (original-query query-object) - open))))) + close))))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Thu Nov 18 15:04:16 2010 @@ -24,5 +24,13 @@ (in-suite sparql-test) +;TODO: prefix tests +;PREFIX foaf : +;PREFIX org: +;PREFIX isi: +;PREFIX : +;PREFIX foaf : " + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests)) \ No newline at end of file From lgiessmann at common-lisp.net Fri Nov 19 09:29:07 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 19 Nov 2010 04:29:07 -0500 Subject: [isidorus-cvs] r342 - trunk/src/TM-SPARQL Message-ID: Author: lgiessmann Date: Fri Nov 19 04:29:06 2010 New Revision: 342 Log: TM-SPARQL: added parsing of BASE statements Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Fri Nov 19 04:29:06 2010 @@ -19,7 +19,8 @@ (defclass SPARQL-Query () ((original-query :initarg :query - :reader original-query + :accessor original-query ;this value is only for internal + ;purposes and mustn't be reset :type String :initform (error (make-condition @@ -27,19 +28,29 @@ :message "From TM-Query(): original-query must be set")) :documentation "Containst the original received querry as string") (prefix-list :initarg :prefix-list - :reader prefix-list + :accessor prefix-list ;this value is only for internal purposes + ;purposes and mustn't be reset :type List :initform nil :documentation "A list of the form ((:label 'id' :value 'prefix'))") + (base-value :initarg :base-value ;initialy the requester's address + :accessor base-value ;this value is only for internal purposes + ;purposes and mustn't be reset + :type String + :initform nil + :documentation "Contains the last set base-value.") (variables :initarg :variables - :accessor :variables + :accessor variables ;this value is only for internal purposes + ;purposes and mustn't be reset :type List :documentation "A list of the form ((:variable var-symbol :value value-object)), that contains tuples for each variable and its result.") (select-statements :initarg :select-statements - :accessor select-statements + :accessor select-statements ;this value is only for + ;internal purposes purposes + ;and mustn't be reset :type List :documentation "A list of the form ((:statement 'statement' :value value-object))"))) @@ -57,7 +68,7 @@ (if existing-tuple (setf (getf existing-tuple :value) prefix-value) (push (list :label prefix-label :value prefix-value) - (slot-value construct 'prefix-list)))))) + (prefix-list construct)))))) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Fri Nov 19 04:29:06 2010 @@ -9,6 +9,7 @@ (in-package :TM-SPARQL) + (defun make-sparql-parser-condition(rest-of-query entire-query expected) "Creates a spqrql-parser-error object." (declare (String rest-of-query entire-query expected)) @@ -20,7 +21,6 @@ (make-condition 'sparql-parser-error :message message))) - (defgeneric parser-start(construct query-string) (:documentation "The entry point of the SPARQL-parser.") (:method ((construct SPARQL-Query) (query-string String)) @@ -31,38 +31,53 @@ (parse-prefixes construct (string-after trimmed-query-string "PREFIX"))) ((string-starts-with trimmed-query-string "BASE") - nil) ;TODO: implement + (parse-base construct (string-after trimmed-query-string "BASE") + #'parser-start)) + ((= (length trimmed-query-string) 0) ;TODO: remove, only for debugging purposes + construct) (t (error (make-sparql-parser-condition trimmed-query-string (original-query construct) "SELECT, PREFIX or BASE"))))))) +(defgeneric parse-base (construct query-string next-fun) + (:documentation "Parses the Base statment and sets the corresponding + attribute in the query-construct. Since the BASE statement + may appear in different states the next-fun defines the next + call function that calls the next transitions and states.") + (:method ((construct SPARQL-Query) (query-string String) (next-fun Function)) + (let* ((trimmed-str (trim-whitespace-left query-string)) + (result (parse-bracketed-value trimmed-str construct))) + (setf (base-value construct) (getf result :value)) + (funcall next-fun construct (getf result :next-query))))) + + (defgeneric parse-prefixes (construct query-string) (:documentation "Sets the correponding prefix-tuples in the passed object.") (:method ((construct SPARQL-Query) (query-string String)) (let ((trimmed-string (trim-whitespace-left query-string))) (if (string-starts-with trimmed-string ":") (let ((results - (parse-bracket-value (subseq trimmed-string 1) construct))) + (parse-bracketed-value (subseq trimmed-string 1) construct))) (add-prefix construct *empty-label* (getf results :value)) - (parser-start construct (getf results :query-string))) + (parser-start construct (getf results :next-query))) (let* ((label-name (trim-whitespace-right (string-until trimmed-string ":"))) (next-query-str (trim-whitespace-left (string-after trimmed-string ":"))) - (results (parse-bracket-value next-query-str construct))) + (results (parse-bracketed-value next-query-str construct))) (when (string= label-name trimmed-string) (error (make-sparql-parser-condition trimmed-string (original-query construct) ":"))) (add-prefix construct label-name (getf results :value)) - (parser-start construct (getf results :query-string))))))) + (parser-start construct (getf results :next-query))))))) -(defun parse-bracket-value(query-string query-object &key (open "<") (close ">")) +(defun parse-bracketed-value(query-string query-object &key (open "<") (close ">")) "A helper function that checks the value of a statement within two brackets, i.e. . A list of the - form (:query-string string :value string) is returned." + form (:next-query string :value string) is returned." (declare (String query-string open close) (SPARQL-Query query-object)) (let ((trimmed-string (trim-whitespace-left query-string))) @@ -73,7 +88,7 @@ (error (make-sparql-parser-condition trimmed-string (original-query query-object) close))) - (list :query-string next-query-str + (list :next-query next-query-str :value pref-url)) (error (make-sparql-parser-condition trimmed-string (original-query query-object) From lgiessmann at common-lisp.net Fri Nov 19 12:22:31 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 19 Nov 2010 07:22:31 -0500 Subject: [isidorus-cvs] r343 - in trunk/src: TM-SPARQL base-tools model unit_tests Message-ID: Author: lgiessmann Date: Fri Nov 19 07:22:30 2010 New Revision: 343 Log: TM-SPARQL: addded the parsing of variables in the SELECT statement; added some unit-tests Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/base-tools/base-tools.lisp trunk/src/model/exceptions.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Fri Nov 19 07:22:30 2010 @@ -24,17 +24,17 @@ :type String :initform (error (make-condition - 'missing-query-string-error + 'missing-argument-error :message "From TM-Query(): original-query must be set")) :documentation "Containst the original received querry as string") - (prefix-list :initarg :prefix-list - :accessor prefix-list ;this value is only for internal purposes - ;purposes and mustn't be reset - :type List - :initform nil - :documentation "A list of the form - ((:label 'id' :value 'prefix'))") - (base-value :initarg :base-value ;initialy the requester's address + (prefixes :initarg :prefixes + :accessor prefixes ;this value is only for internal purposes + ;purposes and mustn't be reset + :type List + :initform nil + :documentation "A list of the form + ((:label 'id' :value 'prefix'))") + (base-value :initarg :base ;initialy the requester's address :accessor base-value ;this value is only for internal purposes ;purposes and mustn't be reset :type String @@ -44,7 +44,8 @@ :accessor variables ;this value is only for internal purposes ;purposes and mustn't be reset :type List - :documentation "A list of the form ((:variable var-symbol + :initform nil + :documentation "A list of the form ((:variable var-name :value value-object)), that contains tuples for each variable and its result.") (select-statements :initarg :select-statements @@ -52,6 +53,7 @@ ;internal purposes purposes ;and mustn't be reset :type List + :initform nil :documentation "A list of the form ((:statement 'statement' :value value-object))"))) @@ -64,15 +66,30 @@ (let ((existing-tuple (find-if #'(lambda(x) (string= (getf x :label) prefix-label)) - (prefix-list construct)))) + (prefixes construct)))) (if existing-tuple (setf (getf existing-tuple :value) prefix-value) (push (list :label prefix-label :value prefix-value) - (prefix-list construct)))))) - + (prefixes construct)))))) + + +(defgeneric add-variable (construct variable-name variable-value) + (:documentation "Adds a new variable-name with its value to the aexisting list. + If a variable-already exists the existing entry will be + overwritten. An entry is of the form + (:variable string :value any-type).") + (:method ((construct SPARQL-Query) (variable-name String) variable-value) + (let ((existing-tuple + (find-if #'(lambda(x) + (string= (getf x :variable) variable-name)) + (variables construct)))) + (if existing-tuple + (setf (getf existing-tuple :value) variable-value) + (push (list :variable variable-name :value variable-value) + (variables construct)))))) (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) - construct) + construct) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Fri Nov 19 07:22:30 2010 @@ -14,9 +14,11 @@ "Creates a spqrql-parser-error object." (declare (String rest-of-query entire-query expected)) (let ((message - (format nil "The query:~%~a bad token on position ~a. Expected: ~a" + (format nil "The query:~%\"~a\"~%~%has a bad token at position ~a => ~a.~%Expected: ~a" entire-query (- (length entire-query) (length rest-of-query)) + (subseq entire-query (- (length entire-query) + (length rest-of-query))) expected))) (make-condition 'sparql-parser-error :message message))) @@ -26,14 +28,17 @@ (:method ((construct SPARQL-Query) (query-string String)) (let ((trimmed-query-string (trim-whitespace-left query-string))) (cond ((string-starts-with trimmed-query-string "SELECT") - nil) ;;TODO: implement + (parse-select + construct (string-after trimmed-query-string "SELECT"))) ((string-starts-with trimmed-query-string "PREFIX") - (parse-prefixes construct - (string-after trimmed-query-string "PREFIX"))) + (parse-prefixes + construct (string-after trimmed-query-string "PREFIX"))) ((string-starts-with trimmed-query-string "BASE") (parse-base construct (string-after trimmed-query-string "BASE") #'parser-start)) - ((= (length trimmed-query-string) 0) ;TODO: remove, only for debugging purposes + ((= (length trimmed-query-string) 0) + ;; If there is only a BASE and/or PREFIX statement return an + ;; query-object with the result nil construct) (t (error (make-sparql-parser-condition @@ -41,6 +46,71 @@ "SELECT, PREFIX or BASE"))))))) +(defgeneric parse-select (construct query-string) + (:documentation "The entry-point of the parsing of the select - where + statement.") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (trim-whitespace-left query-string)) + (next-query (if (string-starts-with trimmed-str "WHERE") + trimmed-str + (parse-variables construct trimmed-str)))) + (unless (string-starts-with next-query "WHERE") + (error (make-sparql-parser-condition + next-query (original-query construct) "WHERE"))) + (let* ((tripples (string-after next-query "WHERE")) + (query-tail (parse-where construct tripples))) + (or query-tail) ;TODO: process tail-of query, e.g. order by, ... + construct)))) + + +(defgeneric parse-where (construct query-string) + (:documentation "The entry-point for the parsing of the WHERE statement.") + (:method ((construct SPARQL-Query) (query-string String)) + )) + + +(defgeneric parse-variables (construct query-string) + (:documentation "Parses the variables of the SELECT statement + and adds them to the passed construct.") + (:method ((construct SPARQL-Query) (query-string String)) + (let ((trimmed-str (trim-whitespace-left query-string))) + (if (string-starts-with trimmed-str "WHERE") + trimmed-str + (let ((result (parse-variable-name trimmed-str construct))) + (add-variable construct (getf result :value) nil) + (parse-variables construct (getf result :next-query))))))) + + +(defun parse-variable-name (query-string query-object) + "A helper function that parses the first non-whitespace character + in the query. since it must be a variable, it must be prefixed + by a ? or $. The return value is of the form + (:next-query string :value string)." + (declare (String query-string) + (SPARQL-Query query-object)) + (let ((trimmed-str (trim-whitespace-left query-string)) + (delimiters (list " " "?" "$" (string #\newline) (string #\tab)))) + (unless (or (string-starts-with trimmed-str "?") + (string-starts-with trimmed-str "$")) + (make-sparql-parser-condition + trimmed-str (original-query query-object) "? or $")) + (let* ((var-name-end (search-first delimiters (subseq trimmed-str 1))) + (var-name + (if var-name-end + (subseq trimmed-str 0 (+ 1 var-name-end)) + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) + "space, newline, tab, ?, $ or WHERE")))) + (next-query (string-after trimmed-str var-name)) + (normalized-var-name + (if (<= (length var-name) 1) + (error (make-sparql-parser-condition + next-query (original-query query-object) + "a variable name")) + (subseq var-name 1)))) + (list :next-query next-query :value normalized-var-name)))) + + (defgeneric parse-base (construct query-string next-fun) (:documentation "Parses the Base statment and sets the corresponding attribute in the query-construct. Since the BASE statement @@ -48,7 +118,7 @@ call function that calls the next transitions and states.") (:method ((construct SPARQL-Query) (query-string String) (next-fun Function)) (let* ((trimmed-str (trim-whitespace-left query-string)) - (result (parse-bracketed-value trimmed-str construct))) + (result (parse-closed-value trimmed-str construct))) (setf (base-value construct) (getf result :value)) (funcall next-fun construct (getf result :next-query))))) @@ -59,14 +129,14 @@ (let ((trimmed-string (trim-whitespace-left query-string))) (if (string-starts-with trimmed-string ":") (let ((results - (parse-bracketed-value (subseq trimmed-string 1) construct))) + (parse-closed-value (subseq trimmed-string 1) construct))) (add-prefix construct *empty-label* (getf results :value)) (parser-start construct (getf results :next-query))) (let* ((label-name (trim-whitespace-right (string-until trimmed-string ":"))) (next-query-str (trim-whitespace-left (string-after trimmed-string ":"))) - (results (parse-bracketed-value next-query-str construct))) + (results (parse-closed-value next-query-str construct))) (when (string= label-name trimmed-string) (error (make-sparql-parser-condition trimmed-string (original-query construct) ":"))) @@ -74,7 +144,7 @@ (parser-start construct (getf results :next-query))))))) -(defun parse-bracketed-value(query-string query-object &key (open "<") (close ">")) +(defun parse-closed-value(query-string query-object &key (open "<") (close ">")) "A helper function that checks the value of a statement within two brackets, i.e. . A list of the form (:next-query string :value string) is returned." Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Fri Nov 19 07:22:30 2010 @@ -20,7 +20,8 @@ :string-starts-with :string-starts-with-char :string-until - :string-after)) + :string-after + :search-first)) (in-package :base-tools) @@ -108,4 +109,18 @@ (let ((pos (search prefix str))) (if pos (subseq str (+ pos (length prefix))) - nil))) \ No newline at end of file + nil))) + + +(defun search-first (search-strings main-string) + "Returns the position of one of the search-strings. The returned position + is the one closest to 0. If no search-string is found, nil is returned." + (declare (String main-string) + (List search-strings)) + (let ((positions + (remove-null (map 'list #'(lambda(search-str) + (search search-str main-string)) + search-strings)))) + (let ((sorted-positions (sort positions #'<))) + (when sorted-positions + (first sorted-positions))))) \ No newline at end of file Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Fri Nov 19 07:22:30 2010 @@ -18,18 +18,11 @@ :missing-argument-error :tm-reference-error :bad-type-error - :missing-query-string-error :sparql-parser-error)) (in-package :exceptions) -(define-condition missing-query-string-error(error) - ((message - :initarg :message - :accessor message))) - - (define-condition sparql-parser-error(error) ((message :initarg :message Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Fri Nov 19 07:22:30 2010 @@ -10,26 +10,138 @@ (defpackage :sparql-test (:use :cl :it.bese.FiveAM - :TM-SPARQL) + :TM-SPARQL + :exceptions) (:export :run-sparql-tests - :sparql-tests)) + :sparql-tests + :test-prefix-and-base)) (in-package :sparql-test) -(def-suite sparql-test +(def-suite sparql-tests :description "tests various key functions of the TM-SPARQL module") -(in-suite sparql-test) +(in-suite sparql-tests) -;TODO: prefix tests -;PREFIX foaf : -;PREFIX org: -;PREFIX isi: -;PREFIX : -;PREFIX foaf : " +(test test-prefix-and-base + "Tests the sparql parser when parsing PREFIX and BASE statements." + (let* ((query-1 "PREFIX foaf : + PREFIX org: + PREFIX isi: + PREFIX : + BASE + PREFIX foaf : + BASE") + (query-2 "PREFIX foaf : + PREFIX org: + + PREFIX isi: + PREFIX +: + BASE + PREFIX foaf : + BASE") + (query-object-1 (make-instance 'SPARQL-Query :query query-1)) + (query-object-2 (make-instance 'SPARQL-Query :query query-2 + :base "http://any-base"))) + (signals missing-argument-error (make-instance 'SPARQL-Query)) + (is-true query-object-1) + (is-true query-object-2) + (is (string= (TM-SPARQL::base-value query-object-1) "http://base.two")) + (is (string= (TM-SPARQL::base-value query-object-2) "http://base.two")) + (is (= (length (TM-SPARQL::prefixes query-object-1)) 4)) + (is (= (length (TM-SPARQL::prefixes query-object-2)) 4)) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "foaf") + (string= (getf elem :value) + "http://overwrite.foaf"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "org") + (string= (getf elem :value) + "http://example.com/ns#"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "isi") + (string= (getf elem :value) + "http://isidor.us"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) + TM-SPARQL::*empty-label*) + (string= (getf elem :value) + "http://some.where"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "foaf") + (string= (getf elem :value) + "http://overwrite.foaf"))) + (TM-SPARQL::prefixes query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "org") + (string= (getf elem :value) + "http://example.com/ns#"))) + (TM-SPARQL::prefixes query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "isi") + (string= (getf elem :value) + "http://isidor.us"))) + (TM-SPARQL::prefixes query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) + TM-SPARQL::*empty-label*) + (string= (getf elem :value) + "http://some.where"))) + (TM-SPARQL::prefixes query-object-2))))) + + +(test test-variable-names + "Tests the sparql parser when parsing variables in the SELECT statement." + (let* ((query-1 "PREFIX foaf : + PREFIX org: + PREFIX isi: + PREFIX : + BASE + PREFIX foaf : + BASE + SELECT ?var1$var2 +$var3 ?var3 WHERE{}") + (query-2 "SELECT ?var1$var2 $var3 ?var3 WHERE{}") + (query-3 "SELECT ?var1$var2 $var3 ?var3WHERE{}") + (query-object-1 (make-instance 'SPARQL-Query :query query-1)) + (query-object-2 (make-instance 'SPARQL-Query :query query-2))) + (is-true query-object-1) + (is-true query-object-2) + (signals sparql-parser-error (make-instance 'SPARQL-Query :query query-3)) + (is (= (length (TM-SPARQL::variables query-object-1)) 3)) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var1") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var2") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var3") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-1))) + (is (= (length (TM-SPARQL::variables query-object-2)) 3)) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var1") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var2") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var3") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-2))))) (defun run-sparql-tests () From lgiessmann at common-lisp.net Sun Nov 21 18:16:32 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 21 Nov 2010 13:16:32 -0500 Subject: [isidorus-cvs] r344 - in trunk/src: . TM-SPARQL base-tools unit_tests xml/rdf xml/xtm Message-ID: Author: lgiessmann Date: Sun Nov 21 13:16:32 2010 New Revision: 344 Log: TM-SAPRQL: added the parsing of tripples in the SELECT-WHERE statement Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/base-tools/base-tools.lisp trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/unit_tests/sparql_test.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/importer.lisp trunk/src/xml/xtm/tools.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sun Nov 21 13:16:32 2010 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :TM-SPARQL - (:use :cl :datamodel :base-tools :exceptions) + (:use :cl :datamodel :base-tools :exceptions :constants) (:export :SPARQL-Query)) @@ -16,8 +16,20 @@ (defvar *empty-label* "_empty_label_symbol") +(defclass Variable-Container () + ((variables :initarg :variables + :accessor variables ;this value is only for internal purposes + ;purposes and mustn't be reset + :type List + :initform nil + :documentation "A list of the form ((:variable var-name + :value value-object)), that contains tuples + for each variable and its result.")) + (:documentation "This class is used to store all variable in a WHERE{} + statement")) -(defclass SPARQL-Query () + +(defclass SPARQL-Query (Variable-Container) ((original-query :initarg :query :accessor original-query ;this value is only for internal ;purposes and mustn't be reset @@ -40,22 +52,15 @@ :type String :initform nil :documentation "Contains the last set base-value.") - (variables :initarg :variables - :accessor variables ;this value is only for internal purposes - ;purposes and mustn't be reset - :type List - :initform nil - :documentation "A list of the form ((:variable var-name - :value value-object)), that contains tuples - for each variable and its result.") (select-statements :initarg :select-statements :accessor select-statements ;this value is only for ;internal purposes purposes ;and mustn't be reset - :type List + :type List :initform nil :documentation "A list of the form ((:statement 'statement' - :value value-object))"))) + :value value-object))")) + (:documentation "This class represents the entire request.")) (defgeneric add-prefix (construct prefix-label prefix-value) @@ -73,12 +78,26 @@ (prefixes construct)))))) +(defgeneric get-prefix (construct string-with-prefix) + (:documentation "Returns the URL corresponding to the found prefix-label + followed by : and the variable. Otherwise the return + value is nil.") + (:method ((construct SPARQL-query) (string-with-prefix String)) + (loop for entry in (prefixes construct) + when (string-starts-with string-with-prefix + (concatenate 'string (getf entry :label) ":")) + return (concatenate + 'string (getf entry :value) ":" + (string-after string-with-prefix + (concatenate 'string (getf entry :label) ":")))))) + + (defgeneric add-variable (construct variable-name variable-value) (:documentation "Adds a new variable-name with its value to the aexisting list. If a variable-already exists the existing entry will be overwritten. An entry is of the form (:variable string :value any-type).") - (:method ((construct SPARQL-Query) (variable-name String) variable-value) + (:method ((construct Variable-Container) (variable-name String) variable-value) (let ((existing-tuple (find-if #'(lambda(x) (string= (getf x :variable) variable-name)) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sun Nov 21 13:16:32 2010 @@ -23,10 +23,23 @@ (make-condition 'sparql-parser-error :message message))) +(defun cut-comment (query-string) + "Returns the given string back. If the query starts with a # or + space # the characters until the nextline are removed." + (declare (String query-string)) + (let ((trimmed-str (trim-whitespace-left query-string))) + (if (string-starts-with trimmed-str "#") + (let ((next-query (string-after trimmed-str (string #\newline)))) + (if next-query + next-query + "")) + trimmed-str))) + + (defgeneric parser-start(construct query-string) (:documentation "The entry point of the SPARQL-parser.") (:method ((construct SPARQL-Query) (query-string String)) - (let ((trimmed-query-string (trim-whitespace-left query-string))) + (let ((trimmed-query-string (cut-comment query-string))) (cond ((string-starts-with trimmed-query-string "SELECT") (parse-select construct (string-after trimmed-query-string "SELECT"))) @@ -50,7 +63,7 @@ (:documentation "The entry-point of the parsing of the select - where statement.") (:method ((construct SPARQL-Query) (query-string String)) - (let* ((trimmed-str (trim-whitespace-left query-string)) + (let* ((trimmed-str (cut-comment query-string)) (next-query (if (string-starts-with trimmed-str "WHERE") trimmed-str (parse-variables construct trimmed-str)))) @@ -66,19 +79,363 @@ (defgeneric parse-where (construct query-string) (:documentation "The entry-point for the parsing of the WHERE statement.") (:method ((construct SPARQL-Query) (query-string String)) - )) + (let ((trimmed-str (cut-comment query-string))) + (unless (string-starts-with trimmed-str "{") + (error (make-sparql-parser-condition trimmed-str + (original-query construct) "{"))) + (parse-group construct (subseq trimmed-str 1) nil)))) + + +(defgeneric parse-group (construct query-string values) + (:documentation "The entry-point for the parsing of a {} statement.") + (:method ((construct SPARQL-Query) (query-string String) (values List)) + (let ((trimmed-str (cut-comment query-string))) + (cond ((string-starts-with trimmed-str "BASE") + (parse-base construct (string-after trimmed-str "BASE") + #'parse-where)) + ((string-starts-with trimmed-str "{") + (error (make-sparql-parser-condition + trimmed-str (original-query construct) + "FILTER, BASE, or tripple. Grouping is currently no implemented."))) + ((string-starts-with trimmed-str "FILTER") + nil) ;TODO: implement => save the filters and call + ;it after invoking parse-tripples + ((string-starts-with trimmed-str "OPTIONAL") + (error (make-sparql-parser-condition + trimmed-str (original-query construct) + "FILTER, BASE, or tripple. Grouping is currently no implemented."))) + ((string-starts-with trimmed-str "UNION") + (error (make-sparql-parser-condition + trimmed-str (original-query construct) + "FILTER, BASE, or tripple. Grouping is currently no implemented."))) + ((string-starts-with trimmed-str "}") ;ending of this group + (subseq trimmed-str 1)) + (t + (parse-tripple construct trimmed-str values)))))) + + +(defun parse-tripple-elem (query-string query-object &key (literal-allowed nil)) + "A helper function to parse a subject or predicate of an RDF tripple. + Returns an entry of the form (:value (:value string :type <'VAR|'IRI|'LITERAL>) + :next-query string)." + (declare (String query-string) + (SPARQL-Query query-object) + (Boolean literal-allowed)) + (let ((trimmed-str (cut-comment query-string))) + (cond ((string-starts-with trimmed-str "<") + (parse-base-suffix-pair trimmed-str query-object)) + ((or (string-starts-with trimmed-str "?") + (string-starts-with trimmed-str "$")) + (let ((result (parse-variable-name trimmed-str query-object))) + (list :next-query (getf result :next-query) + :value (list :value (getf result :value) + :type 'VAR)))) + (t + (if (or (string-starts-with-digit trimmed-str) + (string-starts-with trimmed-str "\"") + (string-starts-with trimmed-str "true") + (string-starts-with trimmed-str "false") + (string-starts-with trimmed-str "'")) + (progn + (unless literal-allowed + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) + "an IRI of the form prefix:suffix or but found a literal."))) + (parse-literal-elem trimmed-str query-object)) + (parse-prefix-suffix-pair trimmed-str query-object)))))) + + +(defun parse-literal-elem (query-string query-object) + "A helper-function that returns a literal vaue of the form + (:value (:value object :literal-type string :literal-lang + string :type <'LITERAL>) :next-query string)." + (declare (String query-string) + (SPARQL-Query query-object)) + (let* ((trimmed-str (cut-comment query-string)) + (value-type-lang-query + (cond ((or (string-starts-with trimmed-str "\"") + (string-starts-with trimmed-str "'")) + (parse-literal-string-value trimmed-str query-object)) + ((string-starts-with trimmed-str "true") + (list :value t :type *xml-boolean* + :next-query (subseq trimmed-str (length "true")))) + ((string-starts-with trimmed-str "false") + (list :value nil :type *xml-boolean* + :next-query (subseq trimmed-str (length "false")))) + ((string-starts-with-digit trimmed-str) + (parse-literal-number-value trimmed-str query-object))))) + (list :next-query (getf value-type-lang-query :next-query) + :value (list :value (getf value-type-lang-query :value) + :literal-type (getf value-type-lang-query :value) + :type 'LITERAL)))) + + +(defun parse-literal-string-value (query-string query-object) + "A helper function that parses a string that is a literal. + The return value is of the form + (list :value object :type string :lang string :next-query string)." + (declare (String query-string) + (SPARQL-Query query-object)) + (let* ((trimmed-str (cut-comment query-string)) + (result-1 (separate-literal-value trimmed-str query-object)) + (after-literal-value (getf result-1 :next-query)) + (l-value (getf result-1 :literal)) + (result-2 (separate-literal-lang-or-type + after-literal-value query-object)) + (l-type (getf result-2 :type)) + (l-lang (if (getf result-2 :lang) + (getf result-2 :lang) + *xml-string*)) + (next-query (getf result-2 :next-query))) + (list :next-query next-query :lang l-lang :type l-lang + :value (cast-literal l-value l-type query-object)))) + + +(defun cast-literal (literal-value literal-type) + "A helper function that casts the passed string value of the literal + corresponding to the passed literal-type." + (declare (String literal-value literal-type)) + (cond ((string= literal-type *xml-string*) + literal-value) + ((string= literal-type *xml-boolean*) + (when (or (string/= literal-value "false") + (string/= literal-value "true")) + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value literal-type)))) + (if (string= literal-value "false") + nil + t)) + ((string= literal-type *xml-integer*) + (handler-case (parse-integer literal-value) + (condition () + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value literal-type)))))) + ((or (string= literal-type *xml-decimal*) ;;both types are + (string= literal-type *xml-double*)) ;;handled the same way + (let ((value (read-from-string literal-value))) + (unless (numberp value) + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value literal-type)))) + value)))) + + +(defun separate-literal-lang-or-type (query-string query-object) + "A helper function that returns (:next-query string :lang string + :type string). Only one of :lang and :type can be set, the other + element is set to nil. The query string must be the string direct + after the closing literal bounding." + (declare (String query-string) + (SPARQL-Query query-object)) + (let ((delimiters (list " ." ". " ";" "}" " " (string #\tab) + (string #\newline)))) + (cond ((string-starts-with query-string "@") + (let ((end-pos (search-first (append delimiters (list ".")) + (subseq query-string 1)))) + (unless end-pos + (error (make-sparql-parser-condition + query-string (original-query query-object) + "'.', ';', '}', ' ', '\t', or '\n'"))) + (list :next-query (subseq (subseq query-string 1) end-pos) + :lang (subseq (subseq query-string 1) 0 end-pos) + :type nil))) + ((string-starts-with query-string "^^") + (let ((end-pos (search-first delimiters (subseq query-string 2)))) + (unless end-pos + (error (make-sparql-parser-condition + query-string (original-query query-object) + "'. ', ,' .', ';', '}', ' ', '\t', or '\n'"))) + (let* ((type-str (subseq (subseq query-string 2) 0 end-pos)) + (next-query (subseq (subseq query-string 2) end-pos)) + (final-type (if (get-prefix query-object type-str) + (get-prefix query-object type-str) + type-str))) + (list :next-query next-query :type final-type :lang nil)))) + (t + (list :next-query query-string :type nil :lang nil))))) + + +(defun separate-literal-value (query-string query-object) + "A helper function that returns (:next-query string :literal string). + The literal string contains the pure literal value." + (declare (String query-string) + (SPARQL-Query query-object)) + (let* ((trimmed-str (cut-comment query-string)) + (delimiter (cond ((string-starts-with trimmed-str "\"") + "\"") + ((string-starts-with trimmed-str "'''") + "'''") + ((string-starts-with trimmed-str "'") + "'") + (t + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) + "a literal starting with ', ''', or \""))))) + (literal-end (find-literal-end (subseq trimmed-str (length delimiter)) + delimiter 0))) + (list :next-query (subseq trimmed-str (+ literal-end (length delimiter))) + :literal (subseq trimmed-str (length delimiter) literal-end)))) + + +(defun find-literal-end (query-string delimiter &optional (overall-pos 0)) + "Returns the end of the literal corresponding to the passed delimiter + string. The query-string must start after the opening literal delimiter. + The return value is an int that represents the start index of closing + delimiter. delimiter must be either \", ', or '''. + If the returns value is nil, there is no closing delimiter." + (declare (String query-string delimiter) + (Integer overall-pos)) + (let ((current-pos (search delimiter query-string))) + (if current-pos + (if (string-ends-with (subseq query-string 0 current-pos) "\\") + (find-literal-end (subseq query-string (+ current-pos + (length delimiter))) + delimiter (+ overall-pos current-pos 1)) + (+ overall-pos current-pos 1)) + nil))) + + +(defun parse-literal-number-value (query-string query-object) + "A helper function that parses any number that is a literal. + The return value is of the form + (list :value nil :type string :pos int)." + (declare (String query-string) + (SPARQL-Query query-object)) + (let* ((trimmed-str (cut-comment query-string)) + (triple-delimiters + (list ". " ". " ";" " " (string #\tab) + (string #\newline) "}")) + (end-pos (search-first triple-delimiters + trimmed-str))) + (unless end-pos + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) + "'. ', ' .', ';' ' ', '\\t', '\\n' or '}'"))) + (let* ((literal-number + (read-from-string (subseq trimmed-str 0 end-pos))) + (number-type + (if (search "." (subseq trimmed-str 0 end-pos)) + *xml-double* ;could also be an xml:decimal, since the doucble has + ;a bigger range it shouldn't matter + *xml-integer*))) + (unless (numberp literal-number) + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) + "a valid number of the form '1', '1.3', 1.0e6'"))) + (list :value literal-number :type number-type + :next-query (subseq trimmed-str end-pos))))) + + +(defun parse-base-suffix-pair (query-string query-object) + "A helper function that returns a list of the form + (list :next-query string :value (:value uri :type 'IRI))." + (declare (String query-string) + (SPARQL-Query query-object)) + (let* ((trimmed-str (cut-comment query-string)) + (result (parse-closed-value trimmed-str query-object)) + (result-uri + (if (or (absolute-uri-p (getf result :value)) + (not (base-value query-object))) + (getf result :value) + (concatenate-uri (base-value query-object) + (getf result :value))))) + (list :next-query (getf result :next-query) + :value (list :value result-uri :type 'IRI)))) + + +(defun parse-prefix-suffix-pair(query-string query-object) + "A helper function that returns a list of the form + (list :next-query string :value (:value uri :type 'IRI))." + (declare (String query-string) + (SPARQL-Query query-object)) + (let* ((trimmed-str (cut-comment query-string)) + (delimiters (list "." ";" "}" "<" " " (string #\newline) + (string #\tab) "#")) + (end-pos (search-first delimiters trimmed-str)) + (elem-str (when end-pos + (subseq trimmed-str 0 end-pos))) + (prefix (when elem-str + (string-until elem-str ":"))) + (suffix (when prefix + (string-after elem-str ":")))) + (unless (and end-pos prefix suffix) + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) + "An IRI of the form prefix:suffix"))) + (list :next-query (string-after + trimmed-str + (concatenate 'string prefix ":" suffix)) + :value (list :value (concatenate 'string prefix ":" suffix) + :type 'IRI)))) + + +(defgeneric parse-tripple (construct query-string values) + (:documentation "Parses a tripple within a trippel group and returns a + a list of the form (:next-query :subject (:type <'VAR|'IRI> + :value string) :predicate (:type <'VAR|'IRI> :value string) + :object (:type <'VAR|'IRI|'LITERAL> :value string)).") + (:method ((construct SPARQL-Query) (query-string String) (values List)) + (let* ((trimmed-str (cut-comment query-string)) + (subject + (let ((result (parse-tripple-elem trimmed-str construct))) + (setf trimmed-str (getf result :next-query)) + (getf result :value))) + (predicate + (let ((result (parse-tripple-elem trimmed-str construct))) + (setf trimmed-str (getf result :next-query)) + (getf result :value))) + (object + (let ((result (parse-tripple-elem trimmed-str construct + :literal-allowed t))) + (setf trimmed-str (getf result :next-query)) + (getf result :value)))) + (or subject object predicate);;TODO: implement + ;; 0) ; => use last subject + ;; 1) search for => if full-url use it otherwise set bse + ;; 2) search for label:suffix + ;; 3) varname => ?|$ + ;; 4) literal => only the object + + ;; => BASE is also allowed + ;; => ;-shortcut + + ;; + ;; + ;; label:pref-suffix + ;; ?var + ;; $var + ;; "literal" + ;; 'literal' + ;; "literal"@language + ;; "literal"^^type + ;; '''"literal"''' + ;; 1, which is the same as "1"^^xsd:integer + ;; 1.3, which is the same as "1.3"^^xsd:decimal + ;; 1.300, which is the same as "1.300"^^xsd:decimal + ;; 1.0e6, which is the same as "1.0e6"^^xsd:double + ;; true, which is the same as "true"^^xsd:boolean + ;; false, which is the same as "false"^^xsd:boolean + ))) (defgeneric parse-variables (construct query-string) (:documentation "Parses the variables of the SELECT statement and adds them to the passed construct.") (:method ((construct SPARQL-Query) (query-string String)) - (let ((trimmed-str (trim-whitespace-left query-string))) + (let ((trimmed-str (cut-comment query-string))) (if (string-starts-with trimmed-str "WHERE") trimmed-str - (let ((result (parse-variable-name trimmed-str construct))) - (add-variable construct (getf result :value) nil) - (parse-variables construct (getf result :next-query))))))) + (if (string-starts-with trimmed-str "*") + (progn (add-variable construct "*" nil) + (parse-variables construct (string-after trimmed-str "*"))) + (let ((result (parse-variable-name trimmed-str construct))) + (add-variable construct (getf result :value) nil) + (parse-variables construct (getf result :next-query)))))))) (defun parse-variable-name (query-string query-object) @@ -88,19 +445,19 @@ (:next-query string :value string)." (declare (String query-string) (SPARQL-Query query-object)) - (let ((trimmed-str (trim-whitespace-left query-string)) - (delimiters (list " " "?" "$" (string #\newline) (string #\tab)))) + (let ((trimmed-str (cut-comment query-string)) + (delimiters (list " " "?" "$" "." (string #\newline) (string #\tab)))) (unless (or (string-starts-with trimmed-str "?") (string-starts-with trimmed-str "$")) - (make-sparql-parser-condition - trimmed-str (original-query query-object) "? or $")) + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) "? or $"))) (let* ((var-name-end (search-first delimiters (subseq trimmed-str 1))) (var-name (if var-name-end (subseq trimmed-str 0 (+ 1 var-name-end)) (error (make-sparql-parser-condition trimmed-str (original-query query-object) - "space, newline, tab, ?, $ or WHERE")))) + "space, newline, tab, ?, ., $ or WHERE")))) (next-query (string-after trimmed-str var-name)) (normalized-var-name (if (<= (length var-name) 1) @@ -117,7 +474,7 @@ may appear in different states the next-fun defines the next call function that calls the next transitions and states.") (:method ((construct SPARQL-Query) (query-string String) (next-fun Function)) - (let* ((trimmed-str (trim-whitespace-left query-string)) + (let* ((trimmed-str (cut-comment query-string)) (result (parse-closed-value trimmed-str construct))) (setf (base-value construct) (getf result :value)) (funcall next-fun construct (getf result :next-query))))) @@ -126,7 +483,7 @@ (defgeneric parse-prefixes (construct query-string) (:documentation "Sets the correponding prefix-tuples in the passed object.") (:method ((construct SPARQL-Query) (query-string String)) - (let ((trimmed-string (trim-whitespace-left query-string))) + (let ((trimmed-string (cut-comment query-string))) (if (string-starts-with trimmed-string ":") (let ((results (parse-closed-value (subseq trimmed-string 1) construct))) @@ -150,7 +507,7 @@ form (:next-query string :value string) is returned." (declare (String query-string open close) (SPARQL-Query query-object)) - (let ((trimmed-string (trim-whitespace-left query-string))) + (let ((trimmed-string (cut-comment query-string))) (if (string-starts-with trimmed-string open) (let* ((pref-url (string-until (string-after trimmed-string open) close)) (next-query-str (string-after trimmed-string close))) @@ -162,43 +519,4 @@ :value pref-url)) (error (make-sparql-parser-condition trimmed-string (original-query query-object) - close))))) - - - -;((PREFIX bounding: )|(PREFIX : )* -;(BASE )*)* -;SELECT ?varName+ -;WHERE { -;(({?subjectOrVarName predicateOrVarName objectOrVarName}?)* -;({?FILTER (filterExpression)}?)* -;(BASE )*)* -;} -;Grouping -;{} -;Base -;BASE -;? -; -;-> uri/book -;Literals -;(?anyCharacter*?)|(?anyCharacter*?)((anyUri)|(@languageTag)){0,1} -; -;Variables -;($anyChar*)|(?anyChar*) -;?var = $var -;Predicate object-lists -;?x foaf:name ?name ; -;foaf:mbox ?mbox . -;This is the same as writing the triple patterns: -;?x foaf:name ?name . -;?x foaf:mbox ?mbox . -;rdf:type -;rdf:type = a -;Empty Graph Pattern -;The group pattern: -;{ } -;matches any graph (including the empty graph) with one solution that does not bind any variables. For example: -;SELECT ?x -;WHERE {} -;matches with one solution in which variable x is not bound." \ No newline at end of file + close))))) \ No newline at end of file Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Sun Nov 21 13:16:32 2010 @@ -18,10 +18,14 @@ :trim-whitespace-right :trim-whitespace :string-starts-with + :string-ends-with :string-starts-with-char :string-until :string-after - :search-first)) + :search-first + :concatenate-uri + :absolute-uri-p + :string-starts-with-digit)) (in-package :base-tools) @@ -81,12 +85,46 @@ (string-trim '(#\Space #\Tab #\Newline) value)) -(defun string-starts-with (str prefix) +(defun string-starts-with (str prefix &key (ignore-case nil)) "Checks if string str starts with a given prefix." - (declare (string str prefix)) - (string= str prefix :start1 0 :end1 - (min (length prefix) - (length str)))) + (declare (String str prefix) + (Boolean ignore-case)) + (let ((str-i (if ignore-case + (string-downcase str :start 0 :end (min (length str) + (length prefix))) + str)) + (prefix-i (if ignore-case + (string-downcase prefix) + prefix))) + (string= str-i prefix-i :start1 0 :end1 + (min (length prefix-i) + (length str-i))))) + + +(defun string-ends-with (str suffix &key (ignore-case nil)) + "Checks if string str ends with a given suffix." + (declare (String str suffix) + (Boolean ignore-case)) + (let ((str-i (if ignore-case + (string-downcase str :start (max (- (length str) + (length suffix)) + 0) + :end (length str)) + str)) + (suffix-i (if ignore-case + (string-downcase suffix) + suffix))) + (string= str-i suffix-i :start1 (max (- (length str) + (length suffix)) + 0)))) + + +(defun string-starts-with-digit (str) + "Checks whether the passed string starts with a digit." + (declare (String str)) + (loop for item in (list 0 1 2 3 4 5 6 7 8 9) + when (string-starts-with str (write-to-string item)) + return t)) (defun string-starts-with-char (begin str) @@ -123,4 +161,53 @@ search-strings)))) (let ((sorted-positions (sort positions #'<))) (when sorted-positions - (first sorted-positions))))) \ No newline at end of file + (first sorted-positions))))) + + +(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 (and (> (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))) + (first-char + (elt value 0))) + (let ((separator + (cond + ((or (eql first-char #\#) + (eql first-char #\/)) + "") + ((or (eql last-char #\#) + (eql last-char #\/)) + "") + (t + "/")))) + (let ((prep-ns + (if (and (eql last-char first-char) + (or (eql last-char #\#) + (eql last-char #\/))) + (subseq absolute-ns 0 (- (length absolute-ns) 1)) + (if (and (eql last-char #\#) + (find #\/ value)) + (progn + (when (not (eql first-char #\/)) + (setf separator "/")) + (subseq absolute-ns 0 (- (length absolute-ns) 1))) + absolute-ns)))) + (concatenate 'string prep-ns separator value))))) + + +(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))))))) \ No newline at end of file Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Sun Nov 21 13:16:32 2010 @@ -26,6 +26,10 @@ :*xml-ns* :*xmlns-ns* :*xml-string* + :*xml-boolean* + :*xml-decimal* + :*xml-double* + :*xml-integer* :*xml-uri* :*rdf2tm-ns* :*rdf-statement* @@ -100,6 +104,14 @@ (defparameter *xml-string* "http://www.w3.org/2001/XMLSchema#string") +(defparameter *xml-boolean* "http://www.w3.org/2001/XMLSchema#boolean") + +(defparameter *xml-integer* "http://www.w3.org/2001/XMLSchema#integer") + +(defparameter *xml-decimal* "http://www.w3.org/2001/XMLSchema#decimal") + +(defparameter *xml-double* "http://www.w3.org/2001/XMLSchema#double") + (defparameter *xml-uri* "http://www.w3.org/2001/XMLSchema#anyURI") (defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/") Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sun Nov 21 13:16:32 2010 @@ -78,8 +78,8 @@ "base-tools")) (:module "atom" :components ((:file "atom") -;; (:file "configuration" -;; :depends-on ("atom")) + ;; (:file "configuration" + ;; :depends-on ("atom")) (:file "collection" :depends-on ("atom")) (:file "snapshots" @@ -156,7 +156,7 @@ (:file "exporter_xtm2.0_test" :depends-on ("fixtures")) (:file "exporter_xtm1.0_test" - :depends-on ("fixtures" "exporter_xtm2.0_test")) + :depends-on ("fixtures" "exporter_xtm2.0_test")) (:file "atom_test" :depends-on ("fixtures")) (:file "json_test" Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sun Nov 21 13:16:32 2010 @@ -111,10 +111,13 @@ $var3 ?var3 WHERE{}") (query-2 "SELECT ?var1$var2 $var3 ?var3 WHERE{}") (query-3 "SELECT ?var1$var2 $var3 ?var3WHERE{}") + (query-4 "SELECT * WHERE{}") (query-object-1 (make-instance 'SPARQL-Query :query query-1)) - (query-object-2 (make-instance 'SPARQL-Query :query query-2))) + (query-object-2 (make-instance 'SPARQL-Query :query query-2)) + (query-object-3 (make-instance 'SPARQL-QUERY :query query-4))) (is-true query-object-1) (is-true query-object-2) + (is-true query-object-3) (signals sparql-parser-error (make-instance 'SPARQL-Query :query query-3)) (is (= (length (TM-SPARQL::variables query-object-1)) 3)) (is-true (find-if #'(lambda(elem) @@ -141,7 +144,11 @@ (is-true (find-if #'(lambda(elem) (and (string= (getf elem :variable) "var3") (null (getf elem :value)))) - (TM-SPARQL::variables query-object-2))))) + (TM-SPARQL::variables query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "*") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-3))))) (defun run-sparql-tests () Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Sun Nov 21 13:16:32 2010 @@ -9,88 +9,8 @@ (defpackage :rdf-importer (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel - :base-tools) - (:import-from :constants - *rdf-ns* - *rdfs-ns* - *xml-ns* - *xmlns-ns* - *xml-string* - *rdf2tm-ns* - *xtm2.0-ns* - *type-instance-psi* - *type-psi* - *instance-psi* - *rdf-statement* - *rdf-object* - *rdf-subject* - *rdf-predicate* - *rdf2tm-object* - *rdf2tm-subject* - *supertype-psi* - *subtype-psi* - *supertype-subtype-psi* - *rdf-nil* - *rdf-first* - *rdf-rest* - *rdf2tm-scope-prefix* - *tm2rdf-topic-type-uri* - *tm2rdf-name-type-uri* - *tm2rdf-name-property* - *tm2rdf-variant-type-uri* - *tm2rdf-variant-property* - *tm2rdf-occurrence-type-uri* - *tm2rdf-occurrence-property* - *tm2rdf-role-type-uri* - *tm2rdf-role-property* - *tm2rdf-association-type-uri* - *tm2rdf-association-property* - *tm2rdf-subjectIdentifier-property* - *tm2rdf-itemIdentity-property* - *tm2rdf-subjectLocator-property* - *tm2rdf-ns* - *tm2rdf-value-property* - *tm2rdf-scope-property* - *tm2rdf-nametype-property* - *tm2rdf-occurrencetype-property* - *tm2rdf-roletype-property* - *tm2rdf-player-property* - *tm2rdf-associationtype-property* - *rdf2tm-blank-node-prefix* - *tm2rdf-reifier-property*) - (:import-from :xml-constants - *rdf_core_psis.xtm* - *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 - absolutize-id - concatenate-uri - node-to-string) - (:import-from :xml-importer - get-uuid - 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) + :base-tools :constants :xml-constants :xml-tools + :xml-importer :isidorus-threading :exceptions) (:export :setup-rdf-module :rdf-importer :init-rdf-module Modified: trunk/src/xml/xtm/importer.lisp ============================================================================== --- trunk/src/xml/xtm/importer.lisp (original) +++ trunk/src/xml/xtm/importer.lisp Sun Nov 21 13:16:32 2010 @@ -72,6 +72,7 @@ :merge-topic-elem-xtm1.0 :from-association-elem-xtm1.0 :importer-xtm1.0 + :get-uuid :with-tm)) (in-package :xml-importer) Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Sun Nov 21 13:16:32 2010 @@ -21,56 +21,16 @@ :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 :absolutize-id - :concatenate-uri :node-to-string)) (in-package :xml-tools) -(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 (and (> (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))) - (first-char - (elt value 0))) - (let ((separator - (cond - ((or (eql first-char #\#) - (eql first-char #\/)) - "") - ((or (eql last-char #\#) - (eql last-char #\/)) - "") - (t - "/")))) - (let ((prep-ns - (if (and (eql last-char first-char) - (or (eql last-char #\#) - (eql last-char #\/))) - (subseq absolute-ns 0 (- (length absolute-ns) 1)) - (if (and (eql last-char #\#) - (find #\/ value)) - (progn - (when (not (eql first-char #\/)) - (setf separator "/")) - (subseq absolute-ns 0 (- (length absolute-ns) 1))) - absolute-ns)))) - (concatenate 'string prep-ns separator value))))) - - (defun absolutize-id (id xml-base tm-id) "Returns the passed id as an absolute uri computed with the given base and tm-id." @@ -206,17 +166,6 @@ 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)) From lgiessmann at common-lisp.net Sun Nov 21 19:57:59 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 21 Nov 2010 14:57:59 -0500 Subject: [isidorus-cvs] r345 - in trunk/src: TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Sun Nov 21 14:57:58 2010 New Revision: 345 Log: TM-SPARQL: fixed a bug by calling the next function from a group-pattern Modified: trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sun Nov 21 14:57:58 2010 @@ -23,6 +23,27 @@ (make-condition 'sparql-parser-error :message message))) +(defun parse-closed-value(query-string query-object &key (open "<") (close ">")) + "A helper function that checks the value of a statement within + two brackets, i.e. . A list of the + form (:next-query string :value string) is returned." + (declare (String query-string open close) + (SPARQL-Query query-object)) + (let ((trimmed-string (cut-comment query-string))) + (if (string-starts-with trimmed-string open) + (let* ((pref-url (string-until (string-after trimmed-string open) close)) + (next-query-str (string-after trimmed-string close))) + (unless next-query-str + (error (make-sparql-parser-condition + trimmed-string (original-query query-object) + close))) + (list :next-query next-query-str + :value pref-url)) + (error (make-sparql-parser-condition + trimmed-string (original-query query-object) + close))))) + + (defun cut-comment (query-string) "Returns the given string back. If the query starts with a # or space # the characters until the nextline are removed." @@ -70,8 +91,8 @@ (unless (string-starts-with next-query "WHERE") (error (make-sparql-parser-condition next-query (original-query construct) "WHERE"))) - (let* ((tripples (string-after next-query "WHERE")) - (query-tail (parse-where construct tripples))) + (let* ((triples (string-after next-query "WHERE")) + (query-tail (parse-where construct triples))) (or query-tail) ;TODO: process tail-of query, e.g. order by, ... construct)))) @@ -83,12 +104,15 @@ (unless (string-starts-with trimmed-str "{") (error (make-sparql-parser-condition trimmed-str (original-query construct) "{"))) - (parse-group construct (subseq trimmed-str 1) nil)))) + (let ((query-tail (parse-group construct (subseq trimmed-str 1) nil nil))) + ;TODO: process query-tail + query-tail)))) -(defgeneric parse-group (construct query-string values) +(defgeneric parse-group (construct query-string values filters) (:documentation "The entry-point for the parsing of a {} statement.") - (:method ((construct SPARQL-Query) (query-string String) (values List)) + (:method ((construct SPARQL-Query) (query-string String) + (values List) (filters List)) (let ((trimmed-str (cut-comment query-string))) (cond ((string-starts-with trimmed-str "BASE") (parse-base construct (string-after trimmed-str "BASE") @@ -96,26 +120,29 @@ ((string-starts-with trimmed-str "{") (error (make-sparql-parser-condition trimmed-str (original-query construct) - "FILTER, BASE, or tripple. Grouping is currently no implemented."))) + "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "FILTER") - nil) ;TODO: implement => save the filters and call - ;it after invoking parse-tripples + nil) ;TODO: call parse-group with added filter ((string-starts-with trimmed-str "OPTIONAL") (error (make-sparql-parser-condition trimmed-str (original-query construct) - "FILTER, BASE, or tripple. Grouping is currently no implemented."))) + "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "UNION") (error (make-sparql-parser-condition trimmed-str (original-query construct) - "FILTER, BASE, or tripple. Grouping is currently no implemented."))) + "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "}") ;ending of this group + ;TODO: invoke filters with all results (subseq trimmed-str 1)) (t - (parse-tripple construct trimmed-str values)))))) + (let ((result (parse-triple construct trimmed-str values))) + (parse-group construct (getf result :next-query) + (getf result :values) filters))))))) + -(defun parse-tripple-elem (query-string query-object &key (literal-allowed nil)) - "A helper function to parse a subject or predicate of an RDF tripple. +(defun parse-triple-elem (query-string query-object &key (literal-allowed nil)) + "A helper function to parse a subject or predicate of an RDF triple. Returns an entry of the form (:value (:value string :type <'VAR|'IRI|'LITERAL>) :next-query string)." (declare (String query-string) @@ -188,7 +215,7 @@ *xml-string*)) (next-query (getf result-2 :next-query))) (list :next-query next-query :lang l-lang :type l-lang - :value (cast-literal l-value l-type query-object)))) + :value (cast-literal l-value l-type)))) (defun cast-literal (literal-value literal-type) @@ -232,10 +259,10 @@ after the closing literal bounding." (declare (String query-string) (SPARQL-Query query-object)) - (let ((delimiters (list " ." ". " ";" "}" " " (string #\tab) + (let ((delimiters (list "." ";" "}" " " (string #\tab) (string #\newline)))) (cond ((string-starts-with query-string "@") - (let ((end-pos (search-first (append delimiters (list ".")) + (let ((end-pos (search-first delimiters (subseq query-string 1)))) (unless end-pos (error (make-sparql-parser-condition @@ -303,19 +330,19 @@ (defun parse-literal-number-value (query-string query-object) "A helper function that parses any number that is a literal. The return value is of the form - (list :value nil :type string :pos int)." + (list :value nil :type string :next-query string." (declare (String query-string) (SPARQL-Query query-object)) (let* ((trimmed-str (cut-comment query-string)) (triple-delimiters - (list ". " ". " ";" " " (string #\tab) + (list ". " ";" " " (string #\tab) (string #\newline) "}")) (end-pos (search-first triple-delimiters trimmed-str))) (unless end-pos (error (make-sparql-parser-condition trimmed-str (original-query query-object) - "'. ', ' .', ';' ' ', '\\t', '\\n' or '}'"))) + "'. ', , ';' ' ', '\\t', '\\n' or '}'"))) (let* ((literal-number (read-from-string (subseq trimmed-str 0 end-pos))) (number-type @@ -374,53 +401,39 @@ :type 'IRI)))) -(defgeneric parse-tripple (construct query-string values) - (:documentation "Parses a tripple within a trippel group and returns a +(defgeneric parse-triple (construct query-string values &key last-subject) + (:documentation "Parses a triple within a trippel group and returns a a list of the form (:next-query :subject (:type <'VAR|'IRI> :value string) :predicate (:type <'VAR|'IRI> :value string) :object (:type <'VAR|'IRI|'LITERAL> :value string)).") - (:method ((construct SPARQL-Query) (query-string String) (values List)) + (:method ((construct SPARQL-Query) (query-string String) (values List) + &key (last-subject nil)) + (declare (List last-subject)) (let* ((trimmed-str (cut-comment query-string)) - (subject - (let ((result (parse-tripple-elem trimmed-str construct))) - (setf trimmed-str (getf result :next-query)) - (getf result :value))) - (predicate - (let ((result (parse-tripple-elem trimmed-str construct))) - (setf trimmed-str (getf result :next-query)) - (getf result :value))) - (object - (let ((result (parse-tripple-elem trimmed-str construct - :literal-allowed t))) - (setf trimmed-str (getf result :next-query)) - (getf result :value)))) - (or subject object predicate);;TODO: implement - ;; 0) ; => use last subject - ;; 1) search for => if full-url use it otherwise set bse - ;; 2) search for label:suffix - ;; 3) varname => ?|$ - ;; 4) literal => only the object - - ;; => BASE is also allowed - ;; => ;-shortcut - - ;; - ;; - ;; label:pref-suffix - ;; ?var - ;; $var - ;; "literal" - ;; 'literal' - ;; "literal"@language - ;; "literal"^^type - ;; '''"literal"''' - ;; 1, which is the same as "1"^^xsd:integer - ;; 1.3, which is the same as "1.3"^^xsd:decimal - ;; 1.300, which is the same as "1.300"^^xsd:decimal - ;; 1.0e6, which is the same as "1.0e6"^^xsd:double - ;; true, which is the same as "true"^^xsd:boolean - ;; false, which is the same as "false"^^xsd:boolean - ))) + (subject-result (if last-subject ;;is used after a ";" + last-subject + (parse-triple-elem trimmed-str construct))) + (predicate-result (parse-triple-elem + (if last-subject + trimmed-str + (getf subject-result :next-query)) + construct)) + (object-result (parse-triple-elem (getf predicate-result :next-query) + construct :literal-allowed t)) + (all-values (append values + (list :subject (getf subject-result :value) + :predicate (getf predicate-result :value) + :object (getf object-result :value))))) + (let ((tr-str (cut-comment (getf object-result :next-query)))) + (cond ((string-starts-with tr-str ";") + (parse-triple construct (subseq tr-str 1) all-values + :last-subject (list :value + (getf subject-result :value)))) + ((string-starts-with tr-str ".") + (parse-triple construct (subseq tr-str 1) all-values)) + ((string-starts-with tr-str "}") ;no other triples follows + (list :next-query tr-str + :values all-values))))))) (defgeneric parse-variables (construct query-string) @@ -498,25 +511,4 @@ (error (make-sparql-parser-condition trimmed-string (original-query construct) ":"))) (add-prefix construct label-name (getf results :value)) - (parser-start construct (getf results :next-query))))))) - - -(defun parse-closed-value(query-string query-object &key (open "<") (close ">")) - "A helper function that checks the value of a statement within - two brackets, i.e. . A list of the - form (:next-query string :value string) is returned." - (declare (String query-string open close) - (SPARQL-Query query-object)) - (let ((trimmed-string (cut-comment query-string))) - (if (string-starts-with trimmed-string open) - (let* ((pref-url (string-until (string-after trimmed-string open) close)) - (next-query-str (string-after trimmed-string close))) - (unless next-query-str - (error (make-sparql-parser-condition - trimmed-string (original-query query-object) - close))) - (list :next-query next-query-str - :value pref-url)) - (error (make-sparql-parser-condition - trimmed-string (original-query query-object) - close))))) \ No newline at end of file + (parser-start construct (getf results :next-query))))))) \ No newline at end of file Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sun Nov 21 14:57:58 2010 @@ -11,7 +11,8 @@ (:use :cl :it.bese.FiveAM :TM-SPARQL - :exceptions) + :exceptions + :constants) (:export :run-sparql-tests :sparql-tests :test-prefix-and-base)) @@ -151,5 +152,19 @@ (TM-SPARQL::variables query-object-3))))) +;(test test-parse-literal-string-value +; "Tests the helper function parse-literal-string-value." +; (let ((query-1 " \"literal-value\"@de.") +; (query-2 "true.") +; (query-3 "false}") +; (query-4 "1234.43e10") +; (query-4 (concatenate 'string "'''true'''\"^^" *xml-boolean* " ;")) + + + ;TODO: delimiter " ;" or " ." + ;TODO: handle: subject predicate object; predicate object +; ) + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests)) \ No newline at end of file From lgiessmann at common-lisp.net Sun Nov 21 21:03:08 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 21 Nov 2010 16:03:08 -0500 Subject: [isidorus-cvs] r346 - in trunk/src: TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Sun Nov 21 16:03:08 2010 New Revision: 346 Log: TM-SPARQL: added some unit-tests for parsing of literals => fixed some bugs Modified: trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sun Nov 21 16:03:08 2010 @@ -193,8 +193,9 @@ (parse-literal-number-value trimmed-str query-object))))) (list :next-query (getf value-type-lang-query :next-query) :value (list :value (getf value-type-lang-query :value) - :literal-type (getf value-type-lang-query :value) - :type 'LITERAL)))) + :literal-type (getf value-type-lang-query :type) + :type 'LITERAL + :literal-lang (getf value-type-lang-query :lang))))) (defun parse-literal-string-value (query-string query-object) @@ -209,12 +210,12 @@ (l-value (getf result-1 :literal)) (result-2 (separate-literal-lang-or-type after-literal-value query-object)) - (l-type (getf result-2 :type)) - (l-lang (if (getf result-2 :lang) - (getf result-2 :lang) + (l-type (if (getf result-2 :type) + (getf result-2 :type) *xml-string*)) + (l-lang (getf result-2 :lang)) (next-query (getf result-2 :next-query))) - (list :next-query next-query :lang l-lang :type l-lang + (list :next-query next-query :lang l-lang :type l-type :value (cast-literal l-value l-type)))) @@ -225,8 +226,8 @@ (cond ((string= literal-type *xml-string*) literal-value) ((string= literal-type *xml-boolean*) - (when (or (string/= literal-value "false") - (string/= literal-value "true")) + (when (and (string/= literal-value "false") + (string/= literal-value "true")) (error (make-condition 'sparql-parser-error :message (format nil "Could not cast from ~a to ~a" @@ -259,10 +260,14 @@ after the closing literal bounding." (declare (String query-string) (SPARQL-Query query-object)) - (let ((delimiters (list "." ";" "}" " " (string #\tab) - (string #\newline)))) + (let ((delimiters-1 (list "." ";" "}" " " (string #\tab) + (string #\newline))) + (delimiters-2 (list " ." ". " ";" "}" " " (string #\tab) + (string #\newline) + (concatenate 'string "." (string #\newline)) + (concatenate 'string "." (string #\tab))))) (cond ((string-starts-with query-string "@") - (let ((end-pos (search-first delimiters + (let ((end-pos (search-first delimiters-1 (subseq query-string 1)))) (unless end-pos (error (make-sparql-parser-condition @@ -272,7 +277,7 @@ :lang (subseq (subseq query-string 1) 0 end-pos) :type nil))) ((string-starts-with query-string "^^") - (let ((end-pos (search-first delimiters (subseq query-string 2)))) + (let ((end-pos (search-first delimiters-2 (subseq query-string 2)))) (unless end-pos (error (make-sparql-parser-condition query-string (original-query query-object) @@ -282,9 +287,10 @@ (final-type (if (get-prefix query-object type-str) (get-prefix query-object type-str) type-str))) - (list :next-query next-query :type final-type :lang nil)))) + (list :next-query (cut-comment next-query) + :type final-type :lang nil)))) (t - (list :next-query query-string :type nil :lang nil))))) + (list :next-query (cut-comment query-string) :type nil :lang nil))))) (defun separate-literal-value (query-string query-object) @@ -323,7 +329,7 @@ (find-literal-end (subseq query-string (+ current-pos (length delimiter))) delimiter (+ overall-pos current-pos 1)) - (+ overall-pos current-pos 1)) + (+ overall-pos current-pos (length delimiter))) nil))) @@ -370,8 +376,9 @@ (not (base-value query-object))) (getf result :value) (concatenate-uri (base-value query-object) - (getf result :value))))) - (list :next-query (getf result :next-query) + (getf result :value)))) + (next-query (getf result :next-query))) + (list :next-query next-query :value (list :value result-uri :type 'IRI)))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sun Nov 21 16:03:08 2010 @@ -15,7 +15,8 @@ :constants) (:export :run-sparql-tests :sparql-tests - :test-prefix-and-base)) + :test-prefix-and-base + :test-parse-literals)) (in-package :sparql-test) @@ -152,18 +153,82 @@ (TM-SPARQL::variables query-object-3))))) -;(test test-parse-literal-string-value -; "Tests the helper function parse-literal-string-value." -; (let ((query-1 " \"literal-value\"@de.") -; (query-2 "true.") -; (query-3 "false}") -; (query-4 "1234.43e10") -; (query-4 (concatenate 'string "'''true'''\"^^" *xml-boolean* " ;")) - - - ;TODO: delimiter " ;" or " ." - ;TODO: handle: subject predicate object; predicate object -; ) +(test test-parse-literals + "Tests the helper functions for parsing literals." + (let ((query-1 " \"literal-value\"@de.") + (query-2 "true.") + (query-3 "false}") + (query-4 (concatenate 'string "1234.43e10" (string #\tab))) + (query-5 (concatenate 'string "'''true'''^^" *xml-boolean* " ;")) + (query-6 (concatenate 'string "'123.4'^^" *xml-double* + "." (string #\newline))) + (query-7 "\"Just a test + +literal with some \\\"quoted\\\" words!\"@en.") + (query-8 (concatenate 'string "'''12.4'''^^" *xml-integer* ". ")) + (query-9 (concatenate 'string "\"13e4\"^^" *xml-boolean* " .")) + (dummy-object (make-instance 'SPARQL-Query :query ""))) + (is-true dummy-object) + (let ((result (tm-sparql::parse-literal-elem query-1 dummy-object))) + (is (string= (getf result :next-query) ".")) + (is (string= (getf (getf result :value) :value) + "literal-value")) + (is (string= (getf (getf result :value) :literal-lang) + "de")) + (is (string= (getf (getf result :value) :literal-type) + *xml-string*)) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (let ((result (tm-sparql::parse-literal-elem query-2 dummy-object))) + (is (string= (getf result :next-query) ".")) + (is (eql (getf (getf result :value) :value) t)) + (is-false (getf (getf result :value) :literal-lang)) + (is (string= (getf (getf result :value) :literal-type) + *xml-boolean*)) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (let ((result (tm-sparql::parse-literal-elem query-3 dummy-object))) + (is (string= (getf result :next-query) "}")) + (is (eql (getf (getf result :value) :value) nil)) + (is-false (getf (getf result :value) :literal-lang)) + (is (string= (getf (getf result :value) :literal-type) + *xml-boolean*)) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (let ((result (tm-sparql::parse-literal-elem query-4 dummy-object))) + (is (string= (getf result :next-query) (string #\tab))) + (is (= (getf (getf result :value) :value) 1234.43e10)) + (is-false (getf (getf result :value) :literal-lang)) + (is (string= (getf (getf result :value) :literal-type) + *xml-double*)) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (let ((result (tm-sparql::parse-literal-elem query-5 dummy-object))) + (is (string= (getf result :next-query) ";")) + (is (eql (getf (getf result :value) :value) t)) + (is-false (getf (getf result :value) :literal-lang)) + (is (string= (getf (getf result :value) :literal-type) + *xml-boolean*)) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (let ((result (tm-sparql::parse-literal-elem query-6 dummy-object))) + (is (string= (getf result :next-query) + (concatenate 'string "." (string #\newline)))) + (is (= (getf (getf result :value) :value) 123.4)) + (is-false (getf (getf result :value) :literal-lang)) + (is (string= (getf (getf result :value) :literal-type) + *xml-double*)) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (let ((result (tm-sparql::parse-literal-elem query-7 dummy-object))) + (is (string= (getf result :next-query) ".")) + (is (string= (getf (getf result :value) :value) + "Just a test + +literal with some \\\"quoted\\\" words!")) + (is (string= (getf (getf result :value) :literal-lang) + "en")) + (is (string= (getf (getf result :value) :literal-type) + *xml-string*)) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (signals sparql-parser-error + (tm-sparql::parse-literal-elem query-8 dummy-object)) + (signals sparql-parser-error + (tm-sparql::parse-literal-elem query-9 dummy-object)))) (defun run-sparql-tests () From lgiessmann at common-lisp.net Mon Nov 22 19:47:02 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 22 Nov 2010 14:47:02 -0500 Subject: [isidorus-cvs] r347 - in trunk/src: TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Mon Nov 22 14:47:01 2010 New Revision: 347 Log: TM-SPARQL: added some unit-tests for parsing variables and IRIs in the SELECT-WHERE-statement => fixed some bugs Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Mon Nov 22 14:47:01 2010 @@ -86,8 +86,8 @@ (loop for entry in (prefixes construct) when (string-starts-with string-with-prefix (concatenate 'string (getf entry :label) ":")) - return (concatenate - 'string (getf entry :value) ":" + return (concatenate-uri + (getf entry :value) (string-after string-with-prefix (concatenate 'string (getf entry :label) ":")))))) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Mon Nov 22 14:47:01 2010 @@ -154,7 +154,7 @@ ((or (string-starts-with trimmed-str "?") (string-starts-with trimmed-str "$")) (let ((result (parse-variable-name trimmed-str query-object))) - (list :next-query (getf result :next-query) + (list :next-query (cut-comment (getf result :next-query)) :value (list :value (getf result :value) :type 'VAR)))) (t @@ -378,7 +378,7 @@ (concatenate-uri (base-value query-object) (getf result :value)))) (next-query (getf result :next-query))) - (list :next-query next-query + (list :next-query (cut-comment next-query) :value (list :value result-uri :type 'IRI)))) @@ -396,15 +396,24 @@ (prefix (when elem-str (string-until elem-str ":"))) (suffix (when prefix - (string-after elem-str ":")))) + (string-after elem-str ":"))) + (full-url + (when (and suffix prefix) + (get-prefix query-object (concatenate 'string prefix ":" suffix))))) (unless (and end-pos prefix suffix) (error (make-sparql-parser-condition trimmed-str (original-query query-object) "An IRI of the form prefix:suffix"))) - (list :next-query (string-after - trimmed-str - (concatenate 'string prefix ":" suffix)) - :value (list :value (concatenate 'string prefix ":" suffix) + (unless full-url + (error (make-condition + 'sparql-parser-error + :message (format nil "The prefix in \"~a:~a\" is not registered" + prefix suffix)))) + (list :next-query (cut-comment + (string-after + trimmed-str + (concatenate 'string prefix ":" suffix))) + :value (list :value full-url :type 'IRI)))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Mon Nov 22 14:47:01 2010 @@ -16,7 +16,8 @@ (:export :run-sparql-tests :sparql-tests :test-prefix-and-base - :test-parse-literals)) + :test-parse-literals + :test-parse-triple-elem)) (in-package :sparql-test) @@ -231,5 +232,49 @@ (tm-sparql::parse-literal-elem query-9 dummy-object)))) +(test test-parse-triple-elem + "Tests various functionality of the parse-triple-elem function." + (let ((query-1 "?var1 .") + (query-2 "$var2 ;") + (query-3 "$var3 }") + (query-4 ".") + (query-5 " }") + (query-6 "pref:suffix .") + (query-7 "pref:suffix}") + (query-8 "preff:suffix}") + (dummy-object (make-instance 'SPARQL-Query :query "" + :base "http://base.value"))) + (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value") + (let ((result (tm-sparql::parse-triple-elem query-1 dummy-object))) + (is (string= (getf result :next-query) ".")) + (is (string= (getf (getf result :value) :value) "var1")) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::VAR))) + (let ((result (tm-sparql::parse-triple-elem query-2 dummy-object))) + (is (string= (getf result :next-query) ";")) + (is (string= (getf (getf result :value) :value) "var2")) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::VAR))) + (let ((result (tm-sparql::parse-triple-elem query-3 dummy-object))) + (is (string= (getf result :next-query) "}")) + (is (string= (getf (getf result :value) :value) "var3")) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::VAR))) + (let ((result (tm-sparql::parse-triple-elem query-4 dummy-object))) + (is (string= (getf result :next-query) ".")) + (is (string= (getf (getf result :value) :value) "http://full.url")) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (let ((result (tm-sparql::parse-triple-elem query-5 dummy-object))) + (is (string= (getf result :next-query) "}")) + (is (string= (getf (getf result :value) :value) "http://base.value/url-suffix")) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (let ((result (tm-sparql::parse-triple-elem query-6 dummy-object))) + (is (string= (getf result :next-query) ".")) + (is (string= (getf (getf result :value) :value) "http://prefix.value/suffix")) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (let ((result (tm-sparql::parse-triple-elem query-7 dummy-object))) + (is (string= (getf result :next-query) "}")) + (is (string= (getf (getf result :value) :value) "http://prefix.value/suffix")) + (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (signals sparql-parser-error + (tm-sparql::parse-triple-elem query-8 dummy-object)))) + (defun run-sparql-tests () - (it.bese.fiveam:run! 'sparql-test:sparql-tests)) \ No newline at end of file + (it.bese.fiveam:run! 'sparql-test:sparql-tests)) From lgiessmann at common-lisp.net Mon Nov 22 20:54:02 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 22 Nov 2010 15:54:02 -0500 Subject: [isidorus-cvs] r348 - in trunk/src: TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Mon Nov 22 15:54:02 2010 New Revision: 348 Log: TM-SPARQL: added some unit-tests for parsing of more triples in a statment => fixed a bug when collecting the values of those triples Modified: trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Mon Nov 22 15:54:02 2010 @@ -419,9 +419,10 @@ (defgeneric parse-triple (construct query-string values &key last-subject) (:documentation "Parses a triple within a trippel group and returns a - a list of the form (:next-query :subject (:type <'VAR|'IRI> - :value string) :predicate (:type <'VAR|'IRI> :value string) - :object (:type <'VAR|'IRI|'LITERAL> :value string)).") + a list of the form (:next-query :values (:subject + (:type <'VAR|'IRI> :value string) :predicate + (:type <'VAR|'IRI> :value string) + :object (:type <'VAR|'IRI|'LITERAL> :value string))).") (:method ((construct SPARQL-Query) (query-string String) (values List) &key (last-subject nil)) (declare (List last-subject)) @@ -437,9 +438,10 @@ (object-result (parse-triple-elem (getf predicate-result :next-query) construct :literal-allowed t)) (all-values (append values - (list :subject (getf subject-result :value) - :predicate (getf predicate-result :value) - :object (getf object-result :value))))) + (list + (list :subject (getf subject-result :value) + :predicate (getf predicate-result :value) + :object (getf object-result :value)))))) (let ((tr-str (cut-comment (getf object-result :next-query)))) (cond ((string-starts-with tr-str ";") (parse-triple construct (subseq tr-str 1) all-values Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Mon Nov 22 15:54:02 2010 @@ -276,5 +276,150 @@ (signals sparql-parser-error (tm-sparql::parse-triple-elem query-8 dummy-object)))) + +(test test-parse-group-1 + "Test various functionality of several functions responsible for parsing + the SELECT-WHERE-statement." + (let ((query-1 "?subject ?predicate $object }") + (query-2 " pref:predicate 1234.5e12}") + (query-3 "pref:subject ?predicate 'literal'@en}") + (dummy-object (make-instance 'SPARQL-Query :query "" + :base "http://base.value/"))) + (is-true dummy-object) + (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value/") + (let ((result (tm-sparql::parse-triple dummy-object query-1 nil))) + (is (string= (getf result :next-query) "}")) + (is (= (length (getf result :values)) 1)) + (is (eql (getf (getf (first (getf result :values)) :subject) :type) + 'TM-SPARQL::VAR)) + (is (string= (getf (getf (first (getf result :values)) :subject) :value) + "subject")) + (is (eql (getf (getf (first (getf result :values)) :predicate) :type) + 'TM-SPARQL::VAR)) + (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + "predicate")) + (is (eql (getf (getf (first (getf result :values)) :object) :type) + 'TM-SPARQL::VAR)) + (is (string= (getf (getf (first (getf result :values)) :object) :value) + "object"))) + (let ((result (tm-sparql::parse-triple dummy-object query-2 nil))) + (is (string= (getf result :next-query) "}")) + (is (eql (getf (getf (first (getf result :values)) :subject) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (first (getf result :values)) :subject) :value) + "http://base.value/subject")) + (is (eql (getf (getf (first (getf result :values)) :predicate) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + "http://prefix.value/predicate")) + (is (eql (getf (getf (first (getf result :values)) :object) :type) + 'TM-SPARQL::LITERAL)) + (is (= (getf (getf (first (getf result :values)) :object) :value) + 1234.5e12)) + (is (string= (getf (getf (first (getf result :values)) :object) + :literal-type) + *xml-double*))) + (let ((result (tm-sparql::parse-triple dummy-object query-3 nil))) + (is (string= (getf result :next-query) "}")) + (is (eql (getf (getf (first (getf result :values)) :subject) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (first (getf result :values)) :subject) :value) + "http://prefix.value/subject")) + (is (eql (getf (getf (first (getf result :values)) :predicate) :type) + 'TM-SPARQL::VAR)) + (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + "predicate")) + (is (eql (getf (getf (first (getf result :values)) :object) :type) + 'TM-SPARQL::LITERAL)) + (is (string= (getf (getf (first (getf result :values)) :object) :value) + "literal")) + (is (string= (getf (getf (first (getf result :values)) :object) + :literal-lang) + "en"))))) + + +(test test-parse-group-2 + "Test various functionality of several functions responsible for parsing + the SELECT-WHERE-statement." + (let ((query-4 (concatenate 'string " '''true'''^^" + *xml-boolean* "; pref:predicate-2 \"12\"^^" + *xml-integer* "}")) + (query-5 (concatenate 'string " '''false'''^^" + *xml-boolean* "; pref:predicate-2 \"abc\"^^" + *xml-string* "}")) + (dummy-object (make-instance 'SPARQL-Query :query "" + :base "http://base.value/"))) + (is-true dummy-object) + (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value/") + (let ((result (tm-sparql::parse-triple dummy-object query-4 nil))) + (is (string= (getf result :next-query) "}")) + (is (= (length (getf result :values)) 2)) + (is (eql (getf (getf (first (getf result :values)) :subject) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (first (getf result :values)) :subject) :value) + "http://base.value/subject")) + (is (eql (getf (getf (first (getf result :values)) :predicate) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + "http://base.value/predicate")) + (is (eql (getf (getf (first (getf result :values)) :object) :type) + 'TM-SPARQL::LITERAL)) + (is (eql (getf (getf (first (getf result :values)) :object) :value) t)) + (is (string= (getf (getf (first (getf result :values)) :object) + :literal-type) + *xml-boolean*)) + (is (string= (getf result :next-query) "}")) + (is (= (length (getf result :values)) 2)) + (is (eql (getf (getf (second (getf result :values)) :subject) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (second (getf result :values)) :subject) :value) + "http://base.value/subject")) + (is (eql (getf (getf (second (getf result :values)) :predicate) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (second (getf result :values)) :predicate) :value) + "http://prefix.value/predicate-2")) + (is (eql (getf (getf (second (getf result :values)) :object) :type) + 'TM-SPARQL::LITERAL)) + (is (= (getf (getf (second (getf result :values)) :object) :value) 12)) + (is (string= (getf (getf (second (getf result :values)) :object) + :literal-type) + *xml-integer*))) + (let ((result (tm-sparql::parse-triple dummy-object query-5 nil))) + (is (string= (getf result :next-query) "}")) + (is (= (length (getf result :values)) 2)) + (is (eql (getf (getf (first (getf result :values)) :subject) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (first (getf result :values)) :subject) :value) + "http://base.value/subject")) + (is (eql (getf (getf (first (getf result :values)) :predicate) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + "http://base.value/predicate")) + (is (eql (getf (getf (first (getf result :values)) :object) :type) + 'TM-SPARQL::LITERAL)) + (is (eql (getf (getf (first (getf result :values)) :object) :value) nil)) + (is (string= (getf (getf (first (getf result :values)) :object) + :literal-type) + *xml-boolean*)) + (is (string= (getf result :next-query) "}")) + (is (= (length (getf result :values)) 2)) + (is (eql (getf (getf (second (getf result :values)) :subject) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (second (getf result :values)) :subject) :value) + "http://base.value/subject")) + (is (eql (getf (getf (second (getf result :values)) :predicate) :type) + 'TM-SPARQL::IRI)) + (is (string= (getf (getf (second (getf result :values)) :predicate) :value) + "http://prefix.value/predicate-2")) + (is (eql (getf (getf (second (getf result :values)) :object) :type) + 'TM-SPARQL::LITERAL)) + (is (string= (getf (getf (second (getf result :values)) :object) :value) + "abc")) + (is (string= (getf (getf (second (getf result :values)) :object) + :literal-type) + *xml-string*))))) + + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests)) From lgiessmann at common-lisp.net Tue Nov 23 16:45:58 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 23 Nov 2010 11:45:58 -0500 Subject: [isidorus-cvs] r349 - in trunk/src: TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Tue Nov 23 11:45:57 2010 New Revision: 349 Log: TM-SPARQL: fixed a recursion bug when parsing SELECT-WHERE-statements Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Tue Nov 23 11:45:57 2010 @@ -16,20 +16,13 @@ (defvar *empty-label* "_empty_label_symbol") -(defclass Variable-Container () - ((variables :initarg :variables - :accessor variables ;this value is only for internal purposes - ;purposes and mustn't be reset - :type List - :initform nil - :documentation "A list of the form ((:variable var-name - :value value-object)), that contains tuples - for each variable and its result.")) - (:documentation "This class is used to store all variable in a WHERE{} - statement")) + +;(defclass SPARQL-Triple () +; (()) +; ) -(defclass SPARQL-Query (Variable-Container) +(defclass SPARQL-Query () ((original-query :initarg :query :accessor original-query ;this value is only for internal ;purposes and mustn't be reset @@ -39,6 +32,14 @@ 'missing-argument-error :message "From TM-Query(): original-query must be set")) :documentation "Containst the original received querry as string") + (variables :initarg :variables + :accessor variables ;this value is only for internal purposes + ;purposes and mustn't be reset + :type List + :initform nil + :documentation "A list of the form ((:variable var-name + :value value-object)), that contains tuples + for each selected variable and its result.") (prefixes :initarg :prefixes :accessor prefixes ;this value is only for internal purposes ;purposes and mustn't be reset @@ -97,7 +98,7 @@ If a variable-already exists the existing entry will be overwritten. An entry is of the form (:variable string :value any-type).") - (:method ((construct Variable-Container) (variable-name String) variable-value) + (:method ((construct SPARQL-Query) (variable-name String) variable-value) (let ((existing-tuple (find-if #'(lambda(x) (string= (getf x :variable) variable-name)) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Tue Nov 23 11:45:57 2010 @@ -104,15 +104,16 @@ (unless (string-starts-with trimmed-str "{") (error (make-sparql-parser-condition trimmed-str (original-query construct) "{"))) - (let ((query-tail (parse-group construct (subseq trimmed-str 1) nil nil))) + (let ((query-tail (parse-group construct (subseq trimmed-str 1)))) ;TODO: process query-tail query-tail)))) -(defgeneric parse-group (construct query-string values filters) +(defgeneric parse-group (construct query-string &key last-subject values filters) (:documentation "The entry-point for the parsing of a {} statement.") (:method ((construct SPARQL-Query) (query-string String) - (values List) (filters List)) + &key (last-subject nil) (values nil) (filters nil)) + (declare (List last-subject values filters)) (let ((trimmed-str (cut-comment query-string))) (cond ((string-starts-with trimmed-str "BASE") (parse-base construct (string-after trimmed-str "BASE") @@ -122,7 +123,7 @@ trimmed-str (original-query construct) "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "FILTER") - nil) ;TODO: call parse-group with added filter + nil) ;TODO: parse-filter and store it ((string-starts-with trimmed-str "OPTIONAL") (error (make-sparql-parser-condition trimmed-str (original-query construct) @@ -135,10 +136,19 @@ ;TODO: invoke filters with all results (subseq trimmed-str 1)) (t - (let ((result (parse-triple construct trimmed-str values))) - (parse-group construct (getf result :next-query) - (getf result :values) filters))))))) - + ;(let ((result + (parse-triple construct trimmed-str :values values + :filters filters :last-subject last-subject)))))) + + +(defun parse-filter (query-string query-object) + "A helper functions that returns a filter and the next-query string + in the form (:next-query string :filter object)." + ;; !, +, -, *, /, (, ), &&, ||, =, !=, <, >, >=, <=, REGEX(string, pattern) + (declare (String query-string) + (SPARQL-Query query-object)) + ;;TODO: implement + (or query-string query-object)) (defun parse-triple-elem (query-string query-object &key (literal-allowed nil)) @@ -417,15 +427,16 @@ :type 'IRI)))) -(defgeneric parse-triple (construct query-string values &key last-subject) +(defgeneric parse-triple (construct query-string + &key last-subject values filters) (:documentation "Parses a triple within a trippel group and returns a a list of the form (:next-query :values (:subject (:type <'VAR|'IRI> :value string) :predicate (:type <'VAR|'IRI> :value string) :object (:type <'VAR|'IRI|'LITERAL> :value string))).") - (:method ((construct SPARQL-Query) (query-string String) (values List) - &key (last-subject nil)) - (declare (List last-subject)) + (:method ((construct SPARQL-Query) (query-string String) + &key (last-subject nil) (values nil) (filters nil)) + (declare (List last-subject filters values)) (let* ((trimmed-str (cut-comment query-string)) (subject-result (if last-subject ;;is used after a ";" last-subject @@ -444,14 +455,17 @@ :object (getf object-result :value)))))) (let ((tr-str (cut-comment (getf object-result :next-query)))) (cond ((string-starts-with tr-str ";") - (parse-triple construct (subseq tr-str 1) all-values - :last-subject (list :value - (getf subject-result :value)))) + (parse-group + construct (subseq tr-str 1) + :last-subject (list :value (getf subject-result :value)) + :values all-values + :filters filters)) ((string-starts-with tr-str ".") - (parse-triple construct (subseq tr-str 1) all-values)) - ((string-starts-with tr-str "}") ;no other triples follows - (list :next-query tr-str - :values all-values))))))) + (parse-group construct (subseq tr-str 1) :values all-values + :filters filters)) + ((string-starts-with tr-str "}") + (parse-group construct tr-str :values all-values + :filters filters))))))) (defgeneric parse-variables (construct query-string) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Nov 23 11:45:57 2010 @@ -17,7 +17,9 @@ :sparql-tests :test-prefix-and-base :test-parse-literals - :test-parse-triple-elem)) + :test-parse-triple-elem + :test-parse-group-1 + :test-parse-group-2)) (in-package :sparql-test) @@ -287,7 +289,7 @@ :base "http://base.value/"))) (is-true dummy-object) (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value/") - (let ((result (tm-sparql::parse-triple dummy-object query-1 nil))) + (let ((result (tm-sparql::parse-triple dummy-object query-1))) (is (string= (getf result :next-query) "}")) (is (= (length (getf result :values)) 1)) (is (eql (getf (getf (first (getf result :values)) :subject) :type) @@ -302,7 +304,7 @@ 'TM-SPARQL::VAR)) (is (string= (getf (getf (first (getf result :values)) :object) :value) "object"))) - (let ((result (tm-sparql::parse-triple dummy-object query-2 nil))) + (let ((result (tm-sparql::parse-triple dummy-object query-2))) (is (string= (getf result :next-query) "}")) (is (eql (getf (getf (first (getf result :values)) :subject) :type) 'TM-SPARQL::IRI)) @@ -319,7 +321,7 @@ (is (string= (getf (getf (first (getf result :values)) :object) :literal-type) *xml-double*))) - (let ((result (tm-sparql::parse-triple dummy-object query-3 nil))) + (let ((result (tm-sparql::parse-triple dummy-object query-3))) (is (string= (getf result :next-query) "}")) (is (eql (getf (getf (first (getf result :values)) :subject) :type) 'TM-SPARQL::IRI)) @@ -338,7 +340,7 @@ "en"))))) -(test test-parse-group-2 +(test test-parse-triple-2 "Test various functionality of several functions responsible for parsing the SELECT-WHERE-statement." (let ((query-4 (concatenate 'string " '''true'''^^" From lgiessmann at common-lisp.net Tue Nov 23 20:10:49 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 23 Nov 2010 15:10:49 -0500 Subject: [isidorus-cvs] r350 - in trunk/src: TM-SPARQL model unit_tests Message-ID: Author: lgiessmann Date: Tue Nov 23 15:10:48 2010 New Revision: 350 Log: TM-SPARQL: fixed a bug with BASE within the select-where statement; extended the object-model of the sparql-interface; adapted all unit-tests of the sparql-interface Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/model/exceptions.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Tue Nov 23 15:10:48 2010 @@ -17,9 +17,60 @@ (defvar *empty-label* "_empty_label_symbol") -;(defclass SPARQL-Triple () -; (()) -; ) +(defclass SPARQL-Triple-Elem() + ((elem-type :initarg :elem-type + :reader elem-type + :type Symbol + :initform (error + (make-condition + 'missing-argument-error + :message "From SPARQL-Triple-Elem(): elem-type must be set")) + :documentation "Contains information about the type of this element + possible values are 'IRI, 'VARIABLE, or 'LITERAL") + (value :initarg :value + :accessor value + :type T + :initform nil + :documentation "Contains the actual value of any type.") + (literal-lang :initarg :literal-lang + :accessor literal-lang + :initform nil + :type String + :documentation "Contains the @lang attribute of a literal") + (literal-type :initarg :literal-type + :accessor literal-type + :type String + :initform nil + :documentation "Contains the datatype of the literal, e.g. xml:string")) + (:documentation "Represents one element of an RDF-triple.")) + + +(defclass SPARQL-Triple() + ((subject :initarg :subject + :accessor subject + :type SPARQL-Triple-Elem + :initform (error + (make-condition + 'missing-argument-error + :message "From SPARQL-Triple(): subject must be set")) + :documentation "Represents the subject of an RDF-triple.") + (predicate :initarg :predicate + :accessor predicate + :type SPARQL-Triple-Elem + :initform (error + (make-condition + 'missing-argument-error + :message "From SPARQL-Triple(): predicate must be set")) + :documentation "Represents the predicate of an RDF-triple.") + (object :initarg :object + :accessor object + :type SPARQL-Triple-Elem + :initform (error + (make-condition + 'missing-argument-error + :message "From SPARQL-Triple-(): object must be set")) + :documentation "Represents the subject of an RDF-triple.")) + (:documentation "Represents an entire RDF-triple.")) (defclass SPARQL-Query () @@ -53,17 +104,36 @@ :type String :initform nil :documentation "Contains the last set base-value.") - (select-statements :initarg :select-statements - :accessor select-statements ;this value is only for - ;internal purposes purposes - ;and mustn't be reset - :type List - :initform nil - :documentation "A list of the form ((:statement 'statement' - :value value-object))")) + (select-group :initarg :select-group + :accessor select-group ;this value is only for + ;internal purposes purposes + ;and mustn't be reset + :type List + :initform nil + :documentation "Contains a SPARQL-Group that represents + the entire inner select-where statement.")) (:documentation "This class represents the entire request.")) +(defgeneric add-triple (construct triple) + (:documentation "Adds a triple object to the select-group list.") + (:method ((construct SPARQL-Query) (triple SPARQL-Triple)) + (push triple (slot-value construct 'select-group)))) + + +(defgeneric (setf elem-type) (construct elem-type) + (:documentation "Sets the passed elem-type on the passed cosntruct.") + (:method ((construct SPARQL-Triple-Elem) (elem-type Symbol)) + (unless (and (eql elem-type 'IRI) + (eql elem-type 'VARIABLE) + (eql elem-type 'LITERAL)) + (error (make-condition + 'bad-argument-error + :message (format nil "Expected a one of the symbols ~a, but get ~a~%" + '('IRI 'VARIABLE 'LITERAL) elem-type)))) + (setf (slot-value construct 'elem-type) elem-type))) + + (defgeneric add-prefix (construct prefix-label prefix-value) (:documentation "Adds the new prefix tuple to the list of all existing. If there already exists a tuple with the same label Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Tue Nov 23 15:10:48 2010 @@ -109,21 +109,23 @@ query-tail)))) -(defgeneric parse-group (construct query-string &key last-subject values filters) +(defgeneric parse-group (construct query-string &key last-subject) (:documentation "The entry-point for the parsing of a {} statement.") (:method ((construct SPARQL-Query) (query-string String) - &key (last-subject nil) (values nil) (filters nil)) - (declare (List last-subject values filters)) + &key (last-subject nil)) + (declare (type (or Null SPARQL-Triple-Elem) last-subject)) (let ((trimmed-str (cut-comment query-string))) (cond ((string-starts-with trimmed-str "BASE") (parse-base construct (string-after trimmed-str "BASE") - #'parse-where)) + #'(lambda(constr query-str) + (parse-group constr query-str + :last-subject last-subject)))) ((string-starts-with trimmed-str "{") (error (make-sparql-parser-condition trimmed-str (original-query construct) "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "FILTER") - nil) ;TODO: parse-filter and store it + nil) ;TODO: parse-filter and store it in construct => extend class ((string-starts-with trimmed-str "OPTIONAL") (error (make-sparql-parser-condition trimmed-str (original-query construct) @@ -133,12 +135,10 @@ trimmed-str (original-query construct) "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "}") ;ending of this group - ;TODO: invoke filters with all results + ;TODO: invoke filters with all results on construct in initialize :after (subseq trimmed-str 1)) (t - ;(let ((result - (parse-triple construct trimmed-str :values values - :filters filters :last-subject last-subject)))))) + (parse-triple construct trimmed-str :last-subject last-subject)))))) (defun parse-filter (query-string query-object) @@ -152,9 +152,7 @@ (defun parse-triple-elem (query-string query-object &key (literal-allowed nil)) - "A helper function to parse a subject or predicate of an RDF triple. - Returns an entry of the form (:value (:value string :type <'VAR|'IRI|'LITERAL>) - :next-query string)." + "A helper function to parse a subject or predicate of an RDF triple." (declare (String query-string) (SPARQL-Query query-object) (Boolean literal-allowed)) @@ -165,8 +163,9 @@ (string-starts-with trimmed-str "$")) (let ((result (parse-variable-name trimmed-str query-object))) (list :next-query (cut-comment (getf result :next-query)) - :value (list :value (getf result :value) - :type 'VAR)))) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'VARIABLE + :value (getf result :value))))) (t (if (or (string-starts-with-digit trimmed-str) (string-starts-with trimmed-str "\"") @@ -202,10 +201,11 @@ ((string-starts-with-digit trimmed-str) (parse-literal-number-value trimmed-str query-object))))) (list :next-query (getf value-type-lang-query :next-query) - :value (list :value (getf value-type-lang-query :value) - :literal-type (getf value-type-lang-query :type) - :type 'LITERAL - :literal-lang (getf value-type-lang-query :lang))))) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'LITERAL + :value (getf value-type-lang-query :value) + :literal-lang (getf value-type-lang-query :lang) + :literal-type (getf value-type-lang-query :type))))) (defun parse-literal-string-value (query-string query-object) @@ -389,7 +389,9 @@ (getf result :value)))) (next-query (getf result :next-query))) (list :next-query (cut-comment next-query) - :value (list :value result-uri :type 'IRI)))) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'IRI + :value result-uri)))) (defun parse-prefix-suffix-pair(query-string query-object) @@ -423,20 +425,15 @@ (string-after trimmed-str (concatenate 'string prefix ":" suffix))) - :value (list :value full-url - :type 'IRI)))) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'IRI + :value full-url)))) -(defgeneric parse-triple (construct query-string - &key last-subject values filters) - (:documentation "Parses a triple within a trippel group and returns a - a list of the form (:next-query :values (:subject - (:type <'VAR|'IRI> :value string) :predicate - (:type <'VAR|'IRI> :value string) - :object (:type <'VAR|'IRI|'LITERAL> :value string))).") - (:method ((construct SPARQL-Query) (query-string String) - &key (last-subject nil) (values nil) (filters nil)) - (declare (List last-subject filters values)) +(defgeneric parse-triple (construct query-string &key last-subject) + (:documentation "Parses a triple within a trippel group.") + (:method ((construct SPARQL-Query) (query-string String) &key (last-subject nil)) + (declare (type (or Null SPARQL-Triple-Elem) last-subject)) (let* ((trimmed-str (cut-comment query-string)) (subject-result (if last-subject ;;is used after a ";" last-subject @@ -444,28 +441,27 @@ (predicate-result (parse-triple-elem (if last-subject trimmed-str - (getf subject-result :next-query)) + (if last-subject + trimmed-str + (getf subject-result :next-query))) construct)) (object-result (parse-triple-elem (getf predicate-result :next-query) - construct :literal-allowed t)) - (all-values (append values - (list - (list :subject (getf subject-result :value) - :predicate (getf predicate-result :value) - :object (getf object-result :value)))))) + construct :literal-allowed t))) + (add-triple construct + (make-instance 'SPARQL-Triple + :subject (if last-subject + last-subject + (getf subject-result :value)) + :predicate (getf predicate-result :value) + :object (getf object-result :value))) (let ((tr-str (cut-comment (getf object-result :next-query)))) (cond ((string-starts-with tr-str ";") - (parse-group - construct (subseq tr-str 1) - :last-subject (list :value (getf subject-result :value)) - :values all-values - :filters filters)) + (parse-group construct (subseq tr-str 1) + :last-subject (getf subject-result :value))) ((string-starts-with tr-str ".") - (parse-group construct (subseq tr-str 1) :values all-values - :filters filters)) + (parse-group construct (subseq tr-str 1))) ((string-starts-with tr-str "}") - (parse-group construct tr-str :values all-values - :filters filters))))))) + (parse-group construct tr-str))))))) (defgeneric parse-variables (construct query-string) Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Tue Nov 23 15:10:48 2010 @@ -18,11 +18,18 @@ :missing-argument-error :tm-reference-error :bad-type-error - :sparql-parser-error)) + :sparql-parser-error + :bad-argument-error)) (in-package :exceptions) +(define-condition bad-argument-error(error) + ((message + :initarg :message + :accessor message))) + + (define-condition sparql-parser-error(error) ((message :initarg :message Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Nov 23 15:10:48 2010 @@ -174,60 +174,59 @@ (is-true dummy-object) (let ((result (tm-sparql::parse-literal-elem query-1 dummy-object))) (is (string= (getf result :next-query) ".")) - (is (string= (getf (getf result :value) :value) + (is (string= (tm-sparql::value (getf result :value)) "literal-value")) - (is (string= (getf (getf result :value) :literal-lang) + (is (string= (tm-sparql::literal-lang (getf result :value)) "de")) - (is (string= (getf (getf result :value) :literal-type) + (is (string= (tm-sparql::literal-type (getf result :value)) *xml-string*)) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-2 dummy-object))) (is (string= (getf result :next-query) ".")) - (is (eql (getf (getf result :value) :value) t)) - (is-false (getf (getf result :value) :literal-lang)) - (is (string= (getf (getf result :value) :literal-type) + (is (eql (tm-sparql::value (getf result :value)) t)) + (is-false (tm-sparql::literal-lang (getf result :value))) + (is (string= (tm-sparql::literal-type (getf result :value)) *xml-boolean*)) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-3 dummy-object))) (is (string= (getf result :next-query) "}")) - (is (eql (getf (getf result :value) :value) nil)) - (is-false (getf (getf result :value) :literal-lang)) - (is (string= (getf (getf result :value) :literal-type) + (is (eql (tm-sparql::value (getf result :value)) nil)) + (is-false (tm-sparql::literal-lang (getf result :value))) + (is (string= (tm-sparql::literal-type (getf result :value)) *xml-boolean*)) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-4 dummy-object))) (is (string= (getf result :next-query) (string #\tab))) - (is (= (getf (getf result :value) :value) 1234.43e10)) - (is-false (getf (getf result :value) :literal-lang)) - (is (string= (getf (getf result :value) :literal-type) + (is (= (tm-sparql::value (getf result :value)) 1234.43e10)) + (is-false (tm-sparql::literal-lang (getf result :value))) + (is (string= (tm-sparql::literal-type (getf result :value)) *xml-double*)) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-5 dummy-object))) (is (string= (getf result :next-query) ";")) - (is (eql (getf (getf result :value) :value) t)) - (is-false (getf (getf result :value) :literal-lang)) - (is (string= (getf (getf result :value) :literal-type) + (is (eql (tm-sparql::value (getf result :value)) t)) + (is-false (tm-sparql::literal-lang (getf result :value))) + (is (string= (tm-sparql::literal-type (getf result :value)) *xml-boolean*)) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-6 dummy-object))) (is (string= (getf result :next-query) (concatenate 'string "." (string #\newline)))) - (is (= (getf (getf result :value) :value) 123.4)) - (is-false (getf (getf result :value) :literal-lang)) - (is (string= (getf (getf result :value) :literal-type) + (is (eql (tm-sparql::value (getf result :value)) 123.4)) + (is-false (tm-sparql::literal-lang (getf result :value))) + (is (string= (tm-sparql::literal-type (getf result :value)) *xml-double*)) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-7 dummy-object))) (is (string= (getf result :next-query) ".")) - (is (string= (getf (getf result :value) :value) + (is (string= (tm-sparql::value (getf result :value)) "Just a test literal with some \\\"quoted\\\" words!")) - (is (string= (getf (getf result :value) :literal-lang) - "en")) - (is (string= (getf (getf result :value) :literal-type) + (is (string= (tm-sparql::literal-lang (getf result :value)) "en")) + (is (string= (tm-sparql::literal-type (getf result :value)) *xml-string*)) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (signals sparql-parser-error (tm-sparql::parse-literal-elem query-8 dummy-object)) (signals sparql-parser-error @@ -245,36 +244,42 @@ (query-7 "pref:suffix}") (query-8 "preff:suffix}") (dummy-object (make-instance 'SPARQL-Query :query "" - :base "http://base.value"))) + :base "http://base.value")) + (var 'TM-SPARQL::VARIABLE) + (iri 'TM-SPARQL::IRI)) (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value") (let ((result (tm-sparql::parse-triple-elem query-1 dummy-object))) (is (string= (getf result :next-query) ".")) - (is (string= (getf (getf result :value) :value) "var1")) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::VAR))) + (is (string= (tm-sparql::value (getf result :value)) "var1")) + (is (eql (tm-sparql::elem-type (getf result :value)) var))) (let ((result (tm-sparql::parse-triple-elem query-2 dummy-object))) (is (string= (getf result :next-query) ";")) - (is (string= (getf (getf result :value) :value) "var2")) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::VAR))) + (is (string= (tm-sparql::value (getf result :value)) "var2")) + (is (eql (tm-sparql::elem-type (getf result :value)) var))) (let ((result (tm-sparql::parse-triple-elem query-3 dummy-object))) (is (string= (getf result :next-query) "}")) - (is (string= (getf (getf result :value) :value) "var3")) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::VAR))) + (is (string= (tm-sparql::value (getf result :value)) "var3")) + (is (eql (tm-sparql::elem-type (getf result :value)) var))) (let ((result (tm-sparql::parse-triple-elem query-4 dummy-object))) (is (string= (getf result :next-query) ".")) - (is (string= (getf (getf result :value) :value) "http://full.url")) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (is (string= (tm-sparql::value (getf result :value)) + "http://full.url")) + (is (eql (tm-sparql::elem-type (getf result :value)) iri))) (let ((result (tm-sparql::parse-triple-elem query-5 dummy-object))) (is (string= (getf result :next-query) "}")) - (is (string= (getf (getf result :value) :value) "http://base.value/url-suffix")) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (is (string= (tm-sparql::value (getf result :value)) + "http://base.value/url-suffix")) + (is (eql (tm-sparql::elem-type (getf result :value)) iri))) (let ((result (tm-sparql::parse-triple-elem query-6 dummy-object))) (is (string= (getf result :next-query) ".")) - (is (string= (getf (getf result :value) :value) "http://prefix.value/suffix")) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (is (string= (tm-sparql::value (getf result :value)) + "http://prefix.value/suffix")) + (is (eql (tm-sparql::elem-type (getf result :value)) iri))) (let ((result (tm-sparql::parse-triple-elem query-7 dummy-object))) (is (string= (getf result :next-query) "}")) - (is (string= (getf (getf result :value) :value) "http://prefix.value/suffix")) - (is (eql (getf (getf result :value) :type) 'TM-SPARQL::IRI))) + (is (string= (tm-sparql::value (getf result :value)) + "http://prefix.value/suffix")) + (is (eql (tm-sparql::elem-type (getf result :value)) iri))) (signals sparql-parser-error (tm-sparql::parse-triple-elem query-8 dummy-object)))) @@ -286,141 +291,121 @@ (query-2 " pref:predicate 1234.5e12}") (query-3 "pref:subject ?predicate 'literal'@en}") (dummy-object (make-instance 'SPARQL-Query :query "" - :base "http://base.value/"))) + :base "http://base.value/")) + (var 'TM-SPARQL::VARIABLE) + (lit 'TM-SPARQL::LITERAL) + (iri 'TM-SPARQL::IRI)) (is-true dummy-object) (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value/") - (let ((result (tm-sparql::parse-triple dummy-object query-1))) - (is (string= (getf result :next-query) "}")) - (is (= (length (getf result :values)) 1)) - (is (eql (getf (getf (first (getf result :values)) :subject) :type) - 'TM-SPARQL::VAR)) - (is (string= (getf (getf (first (getf result :values)) :subject) :value) - "subject")) - (is (eql (getf (getf (first (getf result :values)) :predicate) :type) - 'TM-SPARQL::VAR)) - (is (string= (getf (getf (first (getf result :values)) :predicate) :value) - "predicate")) - (is (eql (getf (getf (first (getf result :values)) :object) :type) - 'TM-SPARQL::VAR)) - (is (string= (getf (getf (first (getf result :values)) :object) :value) - "object"))) - (let ((result (tm-sparql::parse-triple dummy-object query-2))) - (is (string= (getf result :next-query) "}")) - (is (eql (getf (getf (first (getf result :values)) :subject) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (first (getf result :values)) :subject) :value) + (is (string= (tm-sparql::parse-triple dummy-object query-1) "")) + (is (= (length (tm-sparql::select-group dummy-object)) 1)) + (let ((elem (first (tm-sparql::select-group dummy-object)))) + (is (eql (tm-sparql::elem-type (tm-sparql::subject elem)) var)) + (is (string= (tm-sparql::value (tm-sparql::subject elem)) "subject")) + (is (eql (tm-sparql::elem-type (tm-sparql::predicate elem)) var)) + (is (string= (tm-sparql::value (tm-sparql::predicate elem)) "predicate")) + (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) var)) + (is (string= (tm-sparql::value (tm-sparql::object elem)) "object"))) + (is (string= (tm-sparql::parse-triple dummy-object query-2) "")) + (is (= (length (tm-sparql::select-group dummy-object)) 2)) + (let ((elem (first (tm-sparql::select-group dummy-object)))) + (is (eql (tm-sparql::elem-type (tm-sparql::subject elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::subject elem)) "http://base.value/subject")) - (is (eql (getf (getf (first (getf result :values)) :predicate) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + (is (eql (tm-sparql::elem-type (tm-sparql::predicate elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::predicate elem)) "http://prefix.value/predicate")) - (is (eql (getf (getf (first (getf result :values)) :object) :type) - 'TM-SPARQL::LITERAL)) - (is (= (getf (getf (first (getf result :values)) :object) :value) - 1234.5e12)) - (is (string= (getf (getf (first (getf result :values)) :object) - :literal-type) - *xml-double*))) - (let ((result (tm-sparql::parse-triple dummy-object query-3))) - (is (string= (getf result :next-query) "}")) - (is (eql (getf (getf (first (getf result :values)) :subject) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (first (getf result :values)) :subject) :value) + (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) + (is (= (tm-sparql::value (tm-sparql::object elem)) 1234.5e12)) + (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + *xml-double*)) + (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) + (is (string= (tm-sparql::parse-triple dummy-object query-3) "")) + (is (= (length (tm-sparql::select-group dummy-object)) 3)) + (let ((elem (first (tm-sparql::select-group dummy-object)))) + (is (eql (tm-sparql::elem-type (tm-sparql::subject elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::subject elem)) "http://prefix.value/subject")) - (is (eql (getf (getf (first (getf result :values)) :predicate) :type) - 'TM-SPARQL::VAR)) - (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + (is (eql (tm-sparql::elem-type (tm-sparql::predicate elem)) var)) + (is (string= (tm-sparql::value (tm-sparql::predicate elem)) "predicate")) - (is (eql (getf (getf (first (getf result :values)) :object) :type) - 'TM-SPARQL::LITERAL)) - (is (string= (getf (getf (first (getf result :values)) :object) :value) - "literal")) - (is (string= (getf (getf (first (getf result :values)) :object) - :literal-lang) - "en"))))) + (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) + (is (string= (tm-sparql::value (tm-sparql::object elem)) "literal")) + (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + *xml-string*)) + (is (string= (tm-sparql::literal-lang (tm-sparql::object elem)) "en"))))) -(test test-parse-triple-2 +(test test-parse-group-2 "Test various functionality of several functions responsible for parsing the SELECT-WHERE-statement." (let ((query-4 (concatenate 'string " '''true'''^^" *xml-boolean* "; pref:predicate-2 \"12\"^^" *xml-integer* "}")) (query-5 (concatenate 'string " '''false'''^^" - *xml-boolean* "; pref:predicate-2 \"abc\"^^" + *xml-boolean* "; BASE " + " \"abc\"^^" *xml-string* "}")) (dummy-object (make-instance 'SPARQL-Query :query "" - :base "http://base.value/"))) + :base "http://base.value/")) + (lit 'TM-SPARQL::LITERAL) + (iri 'TM-SPARQL::IRI)) (is-true dummy-object) (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value/") - (let ((result (tm-sparql::parse-triple dummy-object query-4 nil))) - (is (string= (getf result :next-query) "}")) - (is (= (length (getf result :values)) 2)) - (is (eql (getf (getf (first (getf result :values)) :subject) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (first (getf result :values)) :subject) :value) + (is (string= (tm-sparql::parse-group dummy-object query-4) "")) + (is (= (length (tm-sparql::select-group dummy-object)) 2)) + (let ((elem (second (tm-sparql::select-group dummy-object)))) + (is (eql (tm-sparql::elem-type (tm-sparql::subject elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::subject elem)) "http://base.value/subject")) - (is (eql (getf (getf (first (getf result :values)) :predicate) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + (is (eql (tm-sparql::elem-type (tm-sparql::predicate elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::predicate elem)) "http://base.value/predicate")) - (is (eql (getf (getf (first (getf result :values)) :object) :type) - 'TM-SPARQL::LITERAL)) - (is (eql (getf (getf (first (getf result :values)) :object) :value) t)) - (is (string= (getf (getf (first (getf result :values)) :object) - :literal-type) + (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) + (is (eql (tm-sparql::value (tm-sparql::object elem)) t)) + (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) *xml-boolean*)) - (is (string= (getf result :next-query) "}")) - (is (= (length (getf result :values)) 2)) - (is (eql (getf (getf (second (getf result :values)) :subject) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (second (getf result :values)) :subject) :value) + (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) + (let ((elem (first (tm-sparql::select-group dummy-object)))) + (is (eql (tm-sparql::elem-type (tm-sparql::subject elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::subject elem)) "http://base.value/subject")) - (is (eql (getf (getf (second (getf result :values)) :predicate) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (second (getf result :values)) :predicate) :value) + (is (eql (tm-sparql::elem-type (tm-sparql::predicate elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::predicate elem)) "http://prefix.value/predicate-2")) - (is (eql (getf (getf (second (getf result :values)) :object) :type) - 'TM-SPARQL::LITERAL)) - (is (= (getf (getf (second (getf result :values)) :object) :value) 12)) - (is (string= (getf (getf (second (getf result :values)) :object) - :literal-type) - *xml-integer*))) - (let ((result (tm-sparql::parse-triple dummy-object query-5 nil))) - (is (string= (getf result :next-query) "}")) - (is (= (length (getf result :values)) 2)) - (is (eql (getf (getf (first (getf result :values)) :subject) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (first (getf result :values)) :subject) :value) + (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) + (is (= (tm-sparql::value (tm-sparql::object elem)) 12)) + (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + *xml-integer*)) + (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) + (is (string= "http://base.value/" (tm-sparql::base-value dummy-object))) + (is (string= (tm-sparql::parse-group dummy-object query-5) "")) + (is (= (length (tm-sparql::select-group dummy-object)) 4)) + (is (string= "http://new.base/" (tm-sparql::base-value dummy-object))) + (let ((elem (second (tm-sparql::select-group dummy-object)))) + (is (eql (tm-sparql::elem-type (tm-sparql::subject elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::subject elem)) "http://base.value/subject")) - (is (eql (getf (getf (first (getf result :values)) :predicate) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (first (getf result :values)) :predicate) :value) + (is (eql (tm-sparql::elem-type (tm-sparql::predicate elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::predicate elem)) "http://base.value/predicate")) - (is (eql (getf (getf (first (getf result :values)) :object) :type) - 'TM-SPARQL::LITERAL)) - (is (eql (getf (getf (first (getf result :values)) :object) :value) nil)) - (is (string= (getf (getf (first (getf result :values)) :object) - :literal-type) + (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) + (is (eql (tm-sparql::value (tm-sparql::object elem)) nil)) + (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) *xml-boolean*)) - (is (string= (getf result :next-query) "}")) - (is (= (length (getf result :values)) 2)) - (is (eql (getf (getf (second (getf result :values)) :subject) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (second (getf result :values)) :subject) :value) + (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) + (let ((elem (first (tm-sparql::select-group dummy-object)))) + (is (eql (tm-sparql::elem-type (tm-sparql::subject elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::subject elem)) "http://base.value/subject")) - (is (eql (getf (getf (second (getf result :values)) :predicate) :type) - 'TM-SPARQL::IRI)) - (is (string= (getf (getf (second (getf result :values)) :predicate) :value) - "http://prefix.value/predicate-2")) - (is (eql (getf (getf (second (getf result :values)) :object) :type) - 'TM-SPARQL::LITERAL)) - (is (string= (getf (getf (second (getf result :values)) :object) :value) - "abc")) - (is (string= (getf (getf (second (getf result :values)) :object) - :literal-type) - *xml-string*))))) - + (is (eql (tm-sparql::elem-type (tm-sparql::predicate elem)) iri)) + (is (string= (tm-sparql::value (tm-sparql::predicate elem)) + "http://new.base/predicate-2")) + (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) + (is (string= (tm-sparql::value (tm-sparql::object elem)) "abc")) + (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + *xml-string*)) + (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))))) (defun run-sparql-tests () From lgiessmann at common-lisp.net Fri Nov 26 10:09:20 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 26 Nov 2010 05:09:20 -0500 Subject: [isidorus-cvs] r351 - in trunk/src: . TM-SPARQL ajax/javascripts Message-ID: Author: lgiessmann Date: Fri Nov 26 05:09:20 2010 New Revision: 351 Log: Isidorus-UI: fixed ticket #96 => set the timeout to 30 seconds to avoid time-out errors; removed the setting of the exteranl-default-format in isidorus.asd, since it should be set explcitly by the end user Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/ajax/javascripts/constants.js trunk/src/constants.lisp trunk/src/isidorus.asd Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Fri Nov 26 05:09:20 2010 @@ -54,6 +54,11 @@ 'missing-argument-error :message "From SPARQL-Triple(): subject must be set")) :documentation "Represents the subject of an RDF-triple.") + (subject-result :initarg :subject-result + :accessor subject-result + :type T + :initform nil + :documentation "Contains the result of the subject triple elem.") (predicate :initarg :predicate :accessor predicate :type SPARQL-Triple-Elem @@ -62,6 +67,12 @@ 'missing-argument-error :message "From SPARQL-Triple(): predicate must be set")) :documentation "Represents the predicate of an RDF-triple.") + (predicate-result :initarg :predicate-result + :accessor predicate-result + :type T + :initform nil + :documentation "Contains the result of the predicate + triple elem.") (object :initarg :object :accessor object :type SPARQL-Triple-Elem @@ -69,7 +80,12 @@ (make-condition 'missing-argument-error :message "From SPARQL-Triple-(): object must be set")) - :documentation "Represents the subject of an RDF-triple.")) + :documentation "Represents the subject of an RDF-triple.") + (object-result :initarg :object-result + :accessor object-result + :type T + :initform nil + :documentation "Contains the result of the object triple elem.")) (:documentation "Represents an entire RDF-triple.")) @@ -179,6 +195,38 @@ (variables construct)))))) + + +;;TODO: +;; +;; find-triples (subject predicate object) +;; * var var var => return the entire graph (all subjects) +;; * var var object +;; * var predicate var +;; * var predicate object +;; * subject var var +;; * subject var object +;; * subject predicate var +;; * subject predicate object => return subject predicate object if true otherweise nil +;; handle special URIs => http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html + +(defgeneric set-result (construct) + (:documentation "Calculates the result of a triple and set all the values in + the passed object.") + (:method ((construct SPARQL-Triple)) + ;;TODO: implement + construct)) + + +(defgeneric find-subject-var-var (construct) + (:documentation "Finds a triple corresponding to the subject and sets + both variables.") + (:method ((construct SPARQL-Triple)) + + )) + + + (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Fri Nov 26 05:09:20 2010 @@ -9,7 +9,6 @@ (in-package :TM-SPARQL) - (defun make-sparql-parser-condition(rest-of-query entire-query expected) "Creates a spqrql-parser-error object." (declare (String rest-of-query entire-query expected)) @@ -157,7 +156,12 @@ (SPARQL-Query query-object) (Boolean literal-allowed)) (let ((trimmed-str (cut-comment query-string))) - (cond ((string-starts-with trimmed-str "<") + (cond ((string-starts-with trimmed-str "a ") ;;rdf:type + (list :next-query (cut-comment (subseq trimmed-str 1)) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'IRI + :value *rdf-type*))) + ((string-starts-with trimmed-str "<") (parse-base-suffix-pair trimmed-str query-object)) ((or (string-starts-with trimmed-str "?") (string-starts-with trimmed-str "$")) @@ -441,9 +445,7 @@ (predicate-result (parse-triple-elem (if last-subject trimmed-str - (if last-subject - trimmed-str - (getf subject-result :next-query))) + (getf subject-result :next-query)) construct)) (object-result (parse-triple-elem (getf predicate-result :next-query) construct :literal-allowed t))) Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Fri Nov 26 05:09:20 2010 @@ -24,7 +24,7 @@ var SUMMARY_URL = HOST_PREF + "json/summary"; var MARK_AS_DELETED_URL = HOST_PREF + "mark-as-deleted"; var TM_OVERVIEW = HOST_PREF + "json/tmcl/overview/"; -var TIMEOUT = 20000; // const TIMEOUT = 10000 --> "const" doesn't work under IE +var TIMEOUT = 30000; // const TIMEOUT = 10000 --> "const" doesn't work under IE Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Fri Nov 26 05:09:20 2010 @@ -39,6 +39,7 @@ :*rdf-nil* :*rdf-first* :*rdf-rest* + :*rdf-type* :*rdf2tm-object* :*rdf2tm-subject* :*rdf2tm-scope-prefix* @@ -126,6 +127,8 @@ (defparameter *rdf-nil* (concatenate 'string *rdf-ns* "nil")) +(defparameter *rdf-type* (concatenate 'string *rdf-ns* "type")) + (defparameter *rdf-first* (concatenate 'string *rdf-ns* "first")) (defparameter *rdf-rest* (concatenate 'string *rdf-ns* "rest")) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Fri Nov 26 05:09:20 2010 @@ -12,8 +12,8 @@ (:use :asdf :cl)) (in-package :isidorus-system) -(defvar *old-external-format* sb-impl::*default-external-format*) -(setf sb-impl::*default-external-format* :UTF-8) +;(defvar *old-external-format* sb-impl::*default-external-format*) ;;should be set by user +;(setf sb-impl::*default-external-format* :UTF-8) (asdf:defsystem "isidorus" :description "The future ingenious, self-evaluating Lisp TM engine" @@ -230,7 +230,9 @@ :uuid :cl-json)) -(setf sb-impl::*default-external-format* *old-external-format*) +;(setf sb-impl::*default-external-format* *old-external-format*) + + ;; ;; For the package pathnames, create a link from ~/.sbcl/systems From lgiessmann at common-lisp.net Fri Nov 26 11:02:29 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 26 Nov 2010 06:02:29 -0500 Subject: [isidorus-cvs] r352 - in trunk/src: ajax/javascripts rest_interface Message-ID: Author: lgiessmann Date: Fri Nov 26 06:02:28 2010 New Revision: 352 Log: Isidorus-UI: fixed ticket #95 => deleted objects are not only deleted in the backend, but also in the frontend, so a recommit of the data contains in the UI does not recreate the removed object Modified: trunk/src/ajax/javascripts/datamodel.js trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Fri Nov 26 06:02:28 2010 @@ -4421,18 +4421,22 @@ makePage(PAGES.home, ""); } else if (type === "Occurrence" || type === "Name"){ - if(objectToDelete.__owner__.__frames__.length > objectToDelete.__max__ - && objectToDelete.__owner__.__frames__.length > 1){ + if(objectToDelete.__owner__.__frames__.length >= 1 && + objectToDelete.__owner__.__frames__.length > objectToDelete.__min__){ objectToDelete.remove(); } else { - if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); } + if(type === "Occurrence"){ + objectToDelete.__value__.setValue(""); + objectToDelete.disable(); + } else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); var vars = objectToDelete.__variants__; objectToDelete.__variants__ = new VariantContainerC(null, objectToDelete); vars.append(objectToDelete.__variants__.getFrame()); vars.remove(); + objectToDelete.disable(); } var ii = objectToDelete.__itemIdentity__; objectToDelete.__itemIdentity__ = new ItemIdentityC(null, objectToDelete); 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 Nov 26 06:02:28 2010 @@ -10,9 +10,10 @@ (in-package :rest-interface) ;caching tables -(defparameter *type-table* nil) -(defparameter *instance-table* nil) - +(defparameter *type-table* nil "Cointains integer==OIDs that represent a topic + instance of a vylid type-topic") +(defparameter *instance-table* nil "Cointains integer==OIDs that represent a topic + instance of a valid instance-topic") ;the prefix to get a fragment by the psi -> localhost:8000/json/get/ (defparameter *json-get-prefix* "/json/get/(.+)$") From lgiessmann at common-lisp.net Fri Nov 26 15:46:51 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 26 Nov 2010 10:46:51 -0500 Subject: [isidorus-cvs] r353 - in trunk/src: json model Message-ID: Author: lgiessmann Date: Fri Nov 26 10:46:50 2010 New Revision: 353 Log: datamodel: fixed ticket #97 => all classes are finalized manually after they are defined Modified: trunk/src/json/json_exporter.lisp trunk/src/model/datamodel.lisp Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Fri Nov 26 10:46:50 2010 @@ -382,18 +382,12 @@ (tm-ids (concatenate 'string "\"tmIds\":" - (if (in-topicmaps (topic instance)) - (let ((j-tm-ids "[")) - (loop for item in (in-topicmaps (topic instance)) - do (setf j-tm-ids - (concatenate - 'string j-tm-ids - (json:encode-json-to-string - (d:uri (first (d:item-identifiers item - :revision revision)))) - ","))) - (concatenate 'string (subseq j-tm-ids 0 (- (length j-tm-ids) 1)) "]")) - "null")))) + (let ((uris + (loop for tm in (in-topicmaps (topic instance)) + collect (map 'list #'d:uri + (item-identifiers tm :revision revision))))) + (concatenate 'string (json:encode-json-to-string + (remove-if #'null uris))))))) (concatenate 'string "{" main-topic "," topicStubs "," associations "," tm-ids "}"))) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri Nov 26 10:46:50 2010 @@ -280,11 +280,6 @@ (:documentation "An abstract base class for all pointers.")) -(defpclass IdentifierC(PointerC) - () - (:documentation "An abstract base class for all TM-Identifiers.")) - - (defpclass TopicIdentificationC(PointerC) ((xtm-id :initarg :xtm-id :accessor xtm-id @@ -298,6 +293,11 @@ representing one of them.")) +(defpclass IdentifierC(PointerC) + () + (:documentation "An abstract base class for all TM-Identifiers.")) + + (defpclass SubjectLocatorC(IdentifierC) () (:index t) @@ -3159,6 +3159,7 @@ construct 'reifier :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item (reifier-topic (first assocs)))))) +1 (defgeneric add-item-identifier (construct item-identifier &key revision) @@ -4417,4 +4418,21 @@ possible-characteristics)))) (when equivalent-construct (merge-constructs (first equivalent-construct) new-characteristic - :revision revision)))))) \ No newline at end of file + :revision revision)))))) + + +;; fixes a bug in elephant, where sb-mop:finalize-inheritance is called too late +(let ((classes + (map 'list #'find-class + (list 'TopicMapConstructC 'PointerC 'IdentifierC 'PersistentIdC + 'ItemIdentifierC 'SubjectLocatorC 'TopicIdentificationC + 'ReifiableConstructC 'TopicC 'TopicMapC 'AssociationC + 'RoleC 'CharacteristicC 'ScopableC 'TypableC 'NameC + 'OccurrenceC 'VariantC 'DatatypableC 'VersionedConstructC + 'VersionedAssociationC 'PointerAssociationC 'ItemIdAssociationC + 'TopicIdAssociationC 'PersistentIdAssociationC + 'SubjectLocatorAssociationC 'ReifierAssociationC + 'CharacteristicAssociationC 'OccurrenceAssociationC + 'NameAssociationC 'VariantAssociationC 'RoleAssociationC + 'ScopeAssociationC 'TypeAssociationC 'PlayerAssociationC)))) + (map 'list #'sb-mop:finalize-inheritance classes)) \ No newline at end of file From lgiessmann at common-lisp.net Fri Nov 26 16:55:18 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 26 Nov 2010 11:55:18 -0500 Subject: [isidorus-cvs] r354 - in trunk/src: ajax/javascripts rest_interface Message-ID: Author: lgiessmann Date: Fri Nov 26 11:55:18 2010 New Revision: 354 Log: REST-interface: splitted the webserver into a webserver for the UI => RDF/XTM/JSON-handlers and into an atom-webserver Modified: trunk/src/ajax/javascripts/datamodel.js trunk/src/rest_interface/rest-interface.lisp Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Fri Nov 26 11:55:18 2010 @@ -4414,7 +4414,6 @@ } commitDeletedObject(delMessage, function(xhr){ - alert("Objected deleted"); if(type === "Topic"){ $(CLASSES.subPage()).update(); setNaviClasses($(PAGES.home)); @@ -4428,7 +4427,6 @@ else { if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); - objectToDelete.disable(); } else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); @@ -4436,13 +4434,14 @@ objectToDelete.__variants__ = new VariantContainerC(null, objectToDelete); vars.append(objectToDelete.__variants__.getFrame()); vars.remove(); - objectToDelete.disable(); } + objectToDelete.disable(); var ii = objectToDelete.__itemIdentity__; objectToDelete.__itemIdentity__ = new ItemIdentityC(null, objectToDelete); ii.append(objectToDelete.__itemIdentity__.getFrame()); ii.remove(); } } + alert("Objected deleted"); }); } \ 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 Fri Nov 26 11:55:18 2010 @@ -25,8 +25,10 @@ :import-tm-feed :read-url :read-fragment-feed - :start-tm-engine - :shutdown-tm-engine + :start-json-engine + :start-atom-engine + :shutdown-json-engine + :shutdown-atom-engine :*json-get-prefix* :*get-rdf-prefix* :*json-commit-url* @@ -61,15 +63,47 @@ (apply page-function (coerce matched-registers 'list)))))))) -(defvar *server-acceptor* nil) +(defvar *json-server-acceptor* nil) +(defvar *atom-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")) +(defun start-json-engine (repository-path &key + (host-name "localhost") (port 8000)) + "Start the Topic Maps Engine on a given port, assuming a given + hostname. Use the repository under repository-path. + This function starts only the json/xtm/rdf handlers for the UI, + The atom interface has to be started separately." + (when *json-server-acceptor* + (error "The json-server is already running")) + (setf hunchentoot:*show-lisp-errors-p* t) ;for now + (setf hunchentoot:*hunchentoot-default-external-format* + (flex:make-external-format :utf-8 :eol-style :lf)) + (unless elephant:*store-controller* + (elephant:open-store + (xml-importer:get-store-spec repository-path))) + (set-up-json-interface) + (setf *json-server-acceptor* + (make-instance 'hunchentoot:acceptor :address host-name :port port)) + (setf hunchentoot:*lisp-errors-log-level* :info) + (setf hunchentoot:*message-log-pathname* "./json-hunchentoot-errors.log") + (hunchentoot:start *json-server-acceptor*)) + + +(defun shutdown-json-engine () + "Shut down the Topic Map Engine, only the json part." + (hunchentoot:stop *json-server-acceptor*) + (setf *json-server-acceptor* nil) + (elephant:close-store)) + + +(defun start-atom-engine (repository-path &key (conf-file "atom/conf.lisp") + (host-name "localhost") (port 8001)) + "Start the Topic Maps Engine on a given port, assuming a given + hostname. Use the repository under repository-path. + This function starts only the atom interface. + The json/xtm/rdf interface has to be started separately." + (when *atom-server-acceptor* + (error "The atom-server is already running")) (setf hunchentoot:*show-lisp-errors-p* t) ;for now (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) @@ -77,16 +111,17 @@ (unless elephant:*store-controller* (elephant:open-store (xml-importer:get-store-spec repository-path))) - (load conffile) + (load conf-file) (publish-feed atom:*tm-feed*) - (set-up-json-interface) - (setf *server-acceptor* (make-instance 'hunchentoot:acceptor :address host-name :port port)) + (setf *atom-server-acceptor* + (make-instance 'hunchentoot:acceptor :address host-name :port port)) (setf hunchentoot:*lisp-errors-log-level* :info) - (setf hunchentoot:*message-log-pathname* "./hunchentoot-errors.log") - (hunchentoot:start *server-acceptor*)) + (setf hunchentoot:*message-log-pathname* "./atom-hunchentoot-errors.log") + (hunchentoot:start *atom-server-acceptor*)) + -(defun shutdown-tm-engine () - "Shut down the Topic Map Engine" - (hunchentoot:stop *server-acceptor*) - (setf *server-acceptor* nil) +(defun shutdown-atom-engine () + "Shut down the Topic Map Engine, only the atom part." + (hunchentoot:stop *atom-server-acceptor*) + (setf *atom-server-acceptor* nil) (elephant:close-store)) \ No newline at end of file From lgiessmann at common-lisp.net Sat Nov 27 16:40:39 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sat, 27 Nov 2010 11:40:39 -0500 Subject: [isidorus-cvs] r355 - in trunk/src: TM-SPARQL model Message-ID: Author: lgiessmann Date: Sat Nov 27 11:40:38 2010 New Revision: 355 Log: TM-SPARQL: fixed ticket #86 => requests without FILTERs can be processed Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/model/datamodel.lisp trunk/src/model/trivial-queries.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sat Nov 27 11:40:38 2010 @@ -11,10 +11,33 @@ (:use :cl :datamodel :base-tools :exceptions :constants) (:export :SPARQL-Query)) +;;TODO: +;; *handle special URIs => http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html (in-package :TM-SPARQL) -(defvar *empty-label* "_empty_label_symbol") +(defvar *empty-label* "_empty_label_symbol" "A label symobl for empyt prefix labels") + +(defvar *equal-operators* nil "A Table taht contains tuples of + classes and equality operators.") + +(defun init-*equal-operators* () + (setf *equal-operators* + (list (list :class 'Boolean :operator #'eql) + (list :class 'String :operator #'string=) + (list :class 'Number :operator #'=)))) + + +(init-*equal-operators*) + + +(defun get-equal-operator (value) + (let ((entry + (find-if #'(lambda(entry) + (typep value (getf entry :class))) + *equal-operators*))) + (when entry + (getf entry :operator)))) (defclass SPARQL-Triple-Elem() @@ -37,11 +60,12 @@ :initform nil :type String :documentation "Contains the @lang attribute of a literal") - (literal-type :initarg :literal-type - :accessor literal-type - :type String - :initform nil - :documentation "Contains the datatype of the literal, e.g. xml:string")) + (literal-datatype :initarg :literal-datatype + :accessor literal-datatype + :type String + :initform nil + :documentation "Contains the datatype of the literal, + e.g. xml:string")) (:documentation "Represents one element of an RDF-triple.")) @@ -195,36 +219,495 @@ (variables construct)))))) - - -;;TODO: -;; -;; find-triples (subject predicate object) -;; * var var var => return the entire graph (all subjects) -;; * var var object -;; * var predicate var -;; * var predicate object -;; * subject var var -;; * subject var object -;; * subject predicate var -;; * subject predicate object => return subject predicate object if true otherweise nil -;; handle special URIs => http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html - -(defgeneric set-result (construct) +(defgeneric set-results (construct &key revision) (:documentation "Calculates the result of a triple and set all the values in the passed object.") + (:method ((construct SPARQL-Triple) &key (revision d:*TM-REVISION*)) + (declare (Integer revision)) + (set-tm-constructs construct :revision revision) + (when (not (iri-not-found-p construct)) ;there is only a result if all IRIs were found + (let ((results (or (filter-by-given-subject construct :revision revision) + (filter-by-given-predicate construct :revision revision) + (filter-by-given-object construct :revision revision)))) + (map 'list #'(lambda(result) + (push (getf result :subject) (subject construct)) + (push (getf result :predicate) (predicate construct)) + (push (getf result :object) (object construct))) + ;;literal-datatype is not used and is not returned, since + ;;the values are returned as object of their specific type, e.g. + ;;integer, boolean, string, ... + results))))) + + +(defgeneric filter-by-given-object (construct &key revision) + (:documentation "Returns a list representing a triple that is the result + of a given object.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (unless (variable-p (object construct)) + (cond ((literal-p (object construct)) + (filter-by-characteristic-value (value (object construct)) + (literal-datatype (object construct)) + :revision revision)) + ((iri-p (object construct)) + (filter-by-otherplayer (value (object construct)) + :revision revision)))))) + + +(defun filter-by-characteristic-value (literal-value literal-datatype + &key (revision *TM-REVISION*)) + "Returns a triple where the passed value is a charvalue in a occurrence + or name. The subject is the owner topic and the predicate is the + characteristic's type." + (declare (Integer revision) + (String literal-value literal-datatype)) + (let ((chars + (cond ((string= literal-datatype *xml-string*) + (remove-if #'(lambda(elem) + (string/= (charvalue elem) literal-value)) + (append + (elephant:get-instances-by-value + 'OccurrenceC 'charvalue literal-value) + (elephant:get-instances-by-value + 'NameC 'charvalue literal-value)))) + ((and (string= literal-datatype *xml-boolean*) + (eql literal-value t)) + (remove-if #'(lambda(elem) + (string/= (charvalue elem) "true")) + (elephant:get-instances-by-value + 'OccurrenceC 'charvalue "true"))) + ((and (string= literal-datatype *xml-boolean*) + (eql literal-value nil)) + (remove-if #'(lambda(elem) + (string/= (charvalue elem) "false")) + (elephant:get-instances-by-value + 'OccurrenceC 'charvalue "false"))) + ((or (string= literal-datatype *xml-double*) + (string= literal-datatype *xml-decimal*) + (string= literal-datatype *xml-integer*)) + (let ((occs + (remove-if #'(lambda(occ) + (string/= (datatype occ) literal-datatype)) + (elephant:get-instances-by-value + 'OccurrenceC 'datatype literal-datatype)))) + (remove-if #'(lambda(occ) + (not (literal= (charvalue occ) literal-value))) + occs)))))) + (remove-null + (map 'list #'(lambda(char) + (let ((subj (when-do top (parent char :revision revision) + (any-id top :revision revision))) + (pred (when-do top (instance-of char :revision revision) + (any-id top :revision revision)))) + (when (and subj pred) + (list :subject subj + :predicate pred + :object (charvalue char) + :literal-datatyp literal-datatype)))) + chars)))) + + +(defgeneric filter-by-otherplayer (construct &key revision) + (:documentation "Returns triples where the passed player is the object, + the other player is the subject and the type of the passed + player's role is the predicate.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (let ((roles-by-oplayer (player-in-roles construct :revision revision)) + (obj-uri (any-id construct :revision revision))) + (remove-null + (map 'list + #'(lambda(role) + (let* ((orole + (when-do assoc (parent role :revision revision) + (when (= (length (roles assoc :revision revision)) + 2) + (find-if #'(lambda(r) (not (eql r role))) + (roles assoc :revision revision))))) + (pred-uri + (when-do type (instance-of role :revision revision) + (any-id type :revision revision))) + (subj-uri + (when-do plr (instance-of orole :revision revision) + (any-id plr :revision revision)))) + (when (and obj-uri pred-uri subj-uri) + (list :subject subj-uri + :predicate pred-uri + :object obj-uri)))) + roles-by-oplayer))))) + + +(defgeneric filter-by-given-predicate (construct &key revision) + (:documentation "Returns all topics that owns a characteristic of the + given type or an associaiton with an otherrole of the + given type. The result is a plist representing a triple.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (and (variable-p (subject construct)) + (iri-p (predicate construct))) + (cond ((variable-p (object construct)) + (append (filter-by-otherroletype construct :revision revision) + (filter-by-characteristictype construct :revision revision))) + ((literal-p (object construct)) + (filter-by-characteristictype construct :revision revision)) + ((iri-p (object construct)) + (filter-by-otherroletype construct :revision revision)))))) + + +(defgeneric filter-by-otherroletype (construct &key revision) + (:documentation "Returns triple where the passed predicate is a + type of a role. The returned subject is the otherplayer, + the predicate is the passed predicate, the object is + the player of the role of the passed type.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (or (variable-p (object construct)) + (iri-p (object construct))) + (let* ((roles-by-type + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'RoleC) + typed-construct)) + (used-as-type construct :revision revision))) + (roles-by-player + (if (iri-p (object construct)) + (remove-null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + (value (object construct))))) + roles-by-type)) + roles-by-type)) + (pred-uri (any-id (value (predicate construct)) :revision revision))) + (remove-null + (map 'list + #'(lambda(role) + (let* ((obj-uri + (when-do plr-top (player role :revision revision) + (any-id plr-top :revision revision))) + (assoc (parent role :revision revision)) + (orole (when (and assoc + (= (length + (roles assoc :revision revision)) + 2)) + (find-if #'(lambda(r) + (not (eql r role))) + (roles assoc :revision revision)))) + (subj-uri + (when-do plr (player orole :revision revision) + (any-id plr :revision revision)))) + (when (and subj-uri pred-uri obj-uri) + (list :subject subj-uri + :predicate pred-uri + :object obj-uri)))) + roles-by-player)))))) + + +(defgeneric filter-by-characteristictype (construct &key revision) + (:documentation "Returns the results of filter-by-nametype and + filter-by-occurrencetype.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (append (filter-by-nametype construct :revision revision) + (filter-by-occurrencetype construct :revision revision)))) + + +(defgeneric filter-by-nametype (construct &key revision) + (:documentation "Returns all names that corresponds to the given parameters.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (and (not (iri-p (object construct))) + (or (not (literal-datatype construct)) + (string= (literal-datatype construct) *xml-string*))) + (let* ((names-by-type + (remove-null + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'NameC) + typed-construct)) + (used-as-type (value (predicate construct)) + :revision revision)))) + (names-by-literal + (if (variable-p (object construct)) + (remove-null + (map 'list #'(lambda(name) + (string= (charvalue name) + (value (object construct)))) + names-by-type)) + names-by-type))) + (remove-null + (map 'list + #'(lambda(name) + (let ((subj + (when-do top (parent name :revision revision) + (any-id top :revision revision))) + (pred + (when-do top (instance-of name :revision revision) + (any-id top :revision revision)))) + (when (and subj pred) + (list :subject subj + :predicate pred + :object (charvalue name) + :literal-datatype *xml-string*)))) + names-by-literal)))))) + + +(defgeneric filter-by-occurrencetype (construct &key revision) + (:documentation "Returns all occurrence that corresponds to the + given parameters.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (unless (iri-p (object construct)) + (let* ((occs-by-type + (remove-null + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'OccurrenceC) + typed-construct)) + (used-as-type (value (predicate construct)) + :revision revision)))) + (all-occs + (let ((literal-value (if (variable-p (object construct)) + nil + (value (object construct)))) + (literal-datatype (literal-datatype (object construct)))) + (remove-null + (map 'list #'(lambda(occ) + (filter-occ-by-value occ literal-value + literal-datatype)) + occs-by-type))))) + (remove-null + (map 'list + #'(lambda(occ) + (let ((subj + (when-do top (parent occ :revision revision) + (any-id top :revision revision))) + (pred + (when-do top (instance-of occ :revision revision) + (any-id top :revision revision)))) + (when (and subj pred) + (list :subject subj + :predicate pred + :object (charvalue occ) + :literal-datatype (datatype occ))))) + all-occs)))))) + + +(defgeneric filter-by-given-subject (construct &key revision) + (:documentation "Calls filter-characteristics and filter associations + for the topic that is set as a subject of the passed triple.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (iri-p (subject construct)) + (let* ((subj (value (subject construct))) + (pred (when (iri-p (predicate construct)) + (value (predicate construct))))) + (cond ((variable-p (object construct)) + (append (filter-characteristics + subj pred nil nil :revision revision) + (filter-associations + subj pred nil :revision revision))) + ((literal-p (object construct)) + (filter-characteristics + subj pred (value (subject construct)) + (literal-datatype (object construct)) :revision revision)) + ((iri-p (object construct)) + (filter-associations subj pred (value (object construct)) + :revision revision))))))) + + +(defgeneric literal-p (construct) + (:documentation "Returns t if the passed construct has an elem-type + set to 'LITERAL.") + (:method ((construct SPARQL-Triple-Elem)) + (eql (elem-type construct) 'LITERAL))) + + +(defgeneric iri-p (construct) + (:documentation "Returns t if the passed construct has an elem-type + set to 'IRI.") + (:method ((construct SPARQL-Triple-Elem)) + (eql (elem-type construct) 'IRI))) + + +(defgeneric variable-p (construct) + (:documentation "Returns t if the passed construct has an elem-type + set to 'VARIABLE.") + (:method ((construct SPARQL-Triple-Elem)) + (eql (elem-type construct) 'VARIABLE))) + + +(defgeneric iri-not-found-p (construct) + (:documentation "Must be called after a call of set-tm-constructs. + It returns t if a TM-construct was not found for a + given IRI, so the result value of a query is nil.") (:method ((construct SPARQL-Triple)) - ;;TODO: implement - construct)) - - -(defgeneric find-subject-var-var (construct) - (:documentation "Finds a triple corresponding to the subject and sets - both variables.") - (:method ((construct SPARQL-Triple)) - - )) - + (or (iri-not-found-p (subject construct)) + (iri-not-found-p (predicate construct)) + (iri-not-found-p (object construct))))) + + +(defmethod iri-not-found-p ((construct SPARQL-Triple-Elem)) + (and (eql (elem-type construct) 'IRI) + (not (value construct)))) + + +(defgeneric set-tm-constructs (construct &key revision) + (:documentation "Calls the method set-tm-construct for every element + in a SPARQL-Triple object.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (when-do subj (subject construct) + (set-tm-construct subj :revision revision)) + (when-do pred (predicate construct) + (set-tm-construct pred :revision revision)) + (when-do obj (object construct) (set-tm-construct obj :revision revision)))) + + +(defgeneric set-tm-construct (construct &key revision) + (:documentation "Replaces the IRI in the given object by the corresponding + TM-construct.") + (:method ((construct SPARQL-Triple-Elem) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (eql (elem-type construct) 'IRI) + (setf (value construct) + (get-item-by-any-id (value construct) :revision revision))))) + + +(defun literal= (value-1 value-2) + "Returns t if both arguments are equal. The equality function is searched in + the table *equal-operators*." + (when (or (and (numberp value-1) (numberp value-2)) + (typep value-1 (type-of value-2)) + (typep value-2 (type-of value-1))) + (let ((operator (get-equal-operator value-1))) + (funcall operator value-1 value-2)))) + + +(defun filter-occ-by-value (occurrence literal-value literal-datatype) + "A helper that compares the occurrence's charvalue with the passed + literal value." + (declare (OccurrenceC occurrence) + (type (or Null String) literal-value literal-datatype)) + (when (or (not literal-datatype) + (string= (datatype occurrence) literal-datatype)) + (if (not literal-value) + occurrence + (handler-case + (let ((occ-value (cast-literal (charvalue occurrence) + (datatype occurrence)))) + (when (literal= occ-value literal-value) + occurrence)) + (condition () nil))))) + + +(defgeneric filter-occurrences(construct type-top literal-value + literal-datatype &key revision) + (:documentation "Returns a list representing a triple.") + (:method ((construct TopicC) type-top literal-value literal-datatype + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null String) literal-value literal-datatype) + (type (or Null TopicC) type-top)) + (let* ((occs-by-type + (occurrences-by-type construct type-top :revision revision)) + (all-occs + (remove-null + (map 'list + #'(lambda(occ) + (filter-occ-by-value occ literal-value literal-datatype)) + occs-by-type))) + (subj-uri (any-id construct :revision revision))) + (remove-null + (map 'list #'(lambda(occ) + (let ((pred-uri + (when-do type-top (instance-of occ :revision revision) + (any-id type-top :revision revision)))) + (when pred-uri + (list :subject subj-uri + :predicate pred-uri + :object (charvalue occ) + :literal-datatype (datatype occ))))) + all-occs))))) + + +(defgeneric filter-names(construct type-top literal-value + &key revision) + (:documentation "Returns a list representing a triple.") + (:method ((construct TopicC) type-top literal-value + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null String) literal-value) + (type (or Null TopicC) type-top)) + (let* ((by-type + (names-by-type construct type-top :revision revision)) + (by-literal (if literal-value + (names-by-value + construct #'(lambda(name) + (string= name literal-value)) + :revision revision) + (names construct :revision revision))) + (all-names (intersection by-type by-literal)) + (subj-uri (any-id construct :revision revision))) + (remove-null + (map 'list #'(lambda(name) + (let ((pred-uri + (when-do type-top (instance-of name :revision revision) + (any-id type-top :revision revision)))) + (when pred-uri + (list :subject subj-uri + :predicate pred-uri + :object (charvalue name) + :literal-datatype *xml-string*)))) + all-names))))) + + +(defgeneric filter-characteristics (construct type-top literal-value + literal-datatype &key revision) + (:documentation "Returns a list representing a triple.") + (:method ((construct TopicC) type-top literal-value literal-datatype + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null String) literal-value literal-datatype) + (type (or Null TopicC) type-top)) + (let ((occs (filter-occurrences construct type-top literal-value + literal-datatype :revision revision)) + (names (if (or (not literal-datatype) + (string= literal-datatype *xml-string*)) + (filter-names construct type-top literal-value + :revision revision) + nil))) + (append occs names)))) + + +(defgeneric filter-associations(construct type-top player-top + &key revision) + (:documentation "Returns a list of the form (:type :value ). + type-identifier is the type of the otherrole and + player-identifier if the otherplayer.") + (:method ((construct TopicC) type-top player-top + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null TopicC) type-top player-top)) + (let ((assocs + (associations-of construct nil nil type-top player-top + :revision revision))) + (remove-null ;only assocs with two roles can match! + (map 'list + #'(lambda(assoc) + (when (= (length (roles assoc :revision revision)) 2) + (let* ((other-role + (find-if #'(lambda(role) + (not (eql construct + (player role :revision revision)))) + (roles assoc :revision revision))) + (pred-uri + (when-do type-top (instance-of other-role + :revision revision) + (any-id type-top :revision revision))) + (obj-uri + (when-do player-top (player other-role + :revision revision) + (any-id player-top :revision revision)))) + (when (and pred-uri obj-uri) + (list :type pred-uri + :value obj-uri))))) + assocs))))) (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sat Nov 27 11:40:38 2010 @@ -92,7 +92,10 @@ next-query (original-query construct) "WHERE"))) (let* ((triples (string-after next-query "WHERE")) (query-tail (parse-where construct triples))) - (or query-tail) ;TODO: process tail-of query, e.g. order by, ... + (when (> (length query-tail) 0) + (error (make-sparql-parser-condition + query-tail (original-query construct) + "The end of the query. Solution sequence modifiers are not supported yet."))) construct)))) @@ -147,7 +150,7 @@ (declare (String query-string) (SPARQL-Query query-object)) ;;TODO: implement - (or query-string query-object)) + ) (defun parse-triple-elem (query-string query-object &key (literal-allowed nil)) @@ -264,8 +267,12 @@ 'sparql-parser-error :message (format nil "Could not cast from ~a to ~a" literal-value literal-type)))) - value)))) - + value)) + (t + (error (make-condition + 'sparql-error + :message (format nil "The type \"~a\" is not supported." + literal-type)))))) (defun separate-literal-lang-or-type (query-string query-object) "A helper function that returns (:next-query string :lang string Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sat Nov 27 11:40:38 2010 @@ -43,6 +43,7 @@ :FragmentC ;;methods, functions and macros + :get-all-identifiers-of-construct :xtm-id :uri :identified-construct @@ -108,6 +109,8 @@ :get-item-by-item-identifier :get-item-by-locator :get-item-by-content + :get-item-by-any-id + :any-id :string-integer-p :with-revision :get-latest-fragment-of-topic @@ -170,6 +173,7 @@ :invoke-on :names-by-type :occurrences-by-type + :occurrences-by-datatype :characteristics-by-type :occurrences-by-value :names-by-value @@ -1028,6 +1032,11 @@ the TM.")) +(defgeneric any-id (construct &key revision) + (:documentation "Returns any uri of the constructs identifier, except + TopicIdentificationC. The order is: PSIs, SL, II.")) + + ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VersionInfocC @@ -1838,6 +1847,28 @@ (item-identifiers construct :revision revision))) +(defun get-item-by-any-id (id-uri &key (revision d:*TM-REVISION*)) + "Returns a topic or REfifiableConstruct corresponding to the given uri." + (declare (String id-uri) + (Integer revision)) + (or (d:get-item-by-psi id-uri :revision revision) + (get-item-by-item-identifier id-uri :revision revision) + (get-item-by-locator id-uri :revision revision))) + + +(defmethod any-id ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (let ((psi (when-do psis (psis construct :revision revision) + (uri (first psis))))) + (if psi + psi + (let ((sl (when-do sls (locators construct :revision revision) + (uri (first sls))))) + (if sl + sl + (call-next-method)))))) + + (defgeneric names (construct &key revision) (:documentation "Returns the NameC-objects that correspond with the passed construct and the passed version.") @@ -3159,7 +3190,6 @@ construct 'reifier :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item (reifier-topic (first assocs)))))) -1 (defgeneric add-item-identifier (construct item-identifier &key revision) @@ -3229,6 +3259,12 @@ construct))) +(defmethod any-id ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when-do iis (item-identifiers construct :revision revision) + (uri (first iis)))) + + (defgeneric add-reifier (construct reifier-topic &key revision) (:documentation "Adds the passed reifier-topic as reifier of the construct. If the construct is already reified by the given topic Modified: trunk/src/model/trivial-queries.lisp ============================================================================== --- trunk/src/model/trivial-queries.lisp (original) +++ trunk/src/model/trivial-queries.lisp Sat Nov 27 11:40:38 2010 @@ -321,6 +321,20 @@ (occurrences-by-value construct filter :revision revision)))) +(defgeneric occurrences-by-datatype (construct datatype &key revision) + (:documentation "Returns all occurrences of the specified datatype.") + (:method ((construct TopicC) datatype &key (revision *TM-REVISION*)) + (declare (type (or Null String) datatype) + (Integer revision)) + (if datatype + (remove-null + (map 'list #'(lambda(occ) + (when (string= (datatype occ) datatype) + occ)) + (occurrences construct :revision revision))) + (occurrences construct :revision revision)))) + + (defgeneric isa (construct type &key revision) (:documentation "Returns all types if the passed construct is of the specified type.") From lgiessmann at common-lisp.net Sun Nov 28 19:47:27 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 28 Nov 2010 14:47:27 -0500 Subject: [isidorus-cvs] r356 - in trunk/src: TM-SPARQL unit_tests Message-ID: Author: lgiessmann Date: Sun Nov 28 14:47:27 2010 New Revision: 356 Log: TM-SPARQL: added some unit-tests for processing single triples in a SELECT-WHERE statement => fixed some bugs in the SPARQL-queries Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/poems.xtm trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sun Nov 28 14:47:27 2010 @@ -114,7 +114,13 @@ (defclass SPARQL-Query () - ((original-query :initarg :query + ((revision :initarg :revision + :accessor revision + :type Integer + :initform 0 + :documentation "Represents the revision in which all the queries + are processed in the DB.") + (original-query :initarg :query :accessor original-query ;this value is only for internal ;purposes and mustn't be reset :type String @@ -230,9 +236,9 @@ (filter-by-given-predicate construct :revision revision) (filter-by-given-object construct :revision revision)))) (map 'list #'(lambda(result) - (push (getf result :subject) (subject construct)) - (push (getf result :predicate) (predicate construct)) - (push (getf result :object) (object construct))) + (push (getf result :subject) (subject-result construct)) + (push (getf result :predicate) (predicate-result construct)) + (push (getf result :object) (object-result construct))) ;;literal-datatype is not used and is not returned, since ;;the values are returned as object of their specific type, e.g. ;;integer, boolean, string, ... @@ -244,7 +250,9 @@ of a given object.") (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) (declare (Integer revision)) - (unless (variable-p (object construct)) + (when (and (not (variable-p (object construct))) + (variable-p (predicate construct)) + (variable-p (subject construct))) (cond ((literal-p (object construct)) (filter-by-characteristic-value (value (object construct)) (literal-datatype (object construct)) @@ -304,7 +312,12 @@ :predicate pred :object (charvalue char) :literal-datatyp literal-datatype)))) - chars)))) + ;;elephant returns names, occurences, and variants if any string + ;;value matches, so all duplicates have to be removed, additionaly + ;;variants have to be remove completely + (remove-if #'(lambda(obj) + (typep obj 'VariantC)) + (remove-duplicates chars)))))) (defgeneric filter-by-otherplayer (construct &key revision) @@ -328,7 +341,7 @@ (when-do type (instance-of role :revision revision) (any-id type :revision revision))) (subj-uri - (when-do plr (instance-of orole :revision revision) + (when-do plr (player orole :revision revision) (any-id plr :revision revision)))) (when (and obj-uri pred-uri subj-uri) (list :subject subj-uri @@ -364,16 +377,18 @@ (when (or (variable-p (object construct)) (iri-p (object construct))) (let* ((roles-by-type - (map 'list #'(lambda(typed-construct) - (when (typep typed-construct 'RoleC) - typed-construct)) - (used-as-type construct :revision revision))) + (remove-null + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'RoleC) + typed-construct)) + (used-as-type (value (predicate construct)) :revision revision)))) (roles-by-player (if (iri-p (object construct)) (remove-null (map 'list #'(lambda(role) - (when (eql (instance-of role :revision revision) - (value (object construct))))) + (when (eql (player role :revision revision) + (value (object construct))) + role)) roles-by-type)) roles-by-type)) (pred-uri (any-id (value (predicate construct)) :revision revision))) @@ -415,7 +430,7 @@ (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) (declare (Integer revision)) (when (and (not (iri-p (object construct))) - (or (not (literal-datatype construct)) + (or (not (literal-datatype (object construct))) (string= (literal-datatype construct) *xml-string*))) (let* ((names-by-type (remove-null @@ -426,12 +441,13 @@ :revision revision)))) (names-by-literal (if (variable-p (object construct)) + names-by-type (remove-null (map 'list #'(lambda(name) - (string= (charvalue name) - (value (object construct)))) - names-by-type)) - names-by-type))) + (when (string= (charvalue name) + (value (object construct))) + name)) + names-by-type))))) (remove-null (map 'list #'(lambda(name) @@ -713,4 +729,6 @@ (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) + (dolist (triple (select-group construct)) + (set-results triple :revision (revision construct))) construct) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sun Nov 28 14:47:27 2010 @@ -208,11 +208,12 @@ ((string-starts-with-digit trimmed-str) (parse-literal-number-value trimmed-str query-object))))) (list :next-query (getf value-type-lang-query :next-query) - :value (make-instance 'SPARQL-Triple-Elem - :elem-type 'LITERAL - :value (getf value-type-lang-query :value) - :literal-lang (getf value-type-lang-query :lang) - :literal-type (getf value-type-lang-query :type))))) + :value (make-instance + 'SPARQL-Triple-Elem + :elem-type 'LITERAL + :value (getf value-type-lang-query :value) + :literal-lang (getf value-type-lang-query :lang) + :literal-datatype (getf value-type-lang-query :type))))) (defun parse-literal-string-value (query-string query-object) Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Sun Nov 28 14:47:27 2010 @@ -1,16 +1,16 @@ - - - - - - - - - - - + + + + + + + + + + + Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sun Nov 28 14:47:27 2010 @@ -12,6 +12,9 @@ :it.bese.FiveAM :TM-SPARQL :exceptions + :unittests-constants + :fixtures + :d :constants) (:export :run-sparql-tests :sparql-tests @@ -19,7 +22,9 @@ :test-parse-literals :test-parse-triple-elem :test-parse-group-1 - :test-parse-group-2)) + :test-parse-group-2 + :test-set-result-1 + :test-set-result-2)) (in-package :sparql-test) @@ -408,5 +413,254 @@ (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))))) +(test test-set-result-1 + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "BASE + SELECT ?subject ?predicate ?object WHERE { + ?subject ?predicate ?object }") + (query-2 "BASE + SELECT $subject ?predicate WHERE{ + ?subject $predicate }") + (query-3 "SELECT ?predicate ?subject WHERE + {?subject ?predicate \"Johann Wolfgang\" }") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) + (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) + (is-true q-obj-1) + (is (= (length (tm-sparql::select-group q-obj-1)) 1)) + (is-true q-obj-2) + (is (= (length (tm-sparql::select-group q-obj-2)) 1)) + (is-true q-obj-3) + (is (= (length (tm-sparql::select-group q-obj-3)) 1)) + (is-false (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1)))) + (is-false (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1)))) + (is-false (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1)))) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2)))) 2)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2)))) 2)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2)))) 2)) + (let ((subj-1 (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (subj-2 (second (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (pred-1 (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (pred-2 (second (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (obj-1 (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2))))) + (obj-2 (second (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2)))))) + (cond ((or (string= subj-1 "http://some.where/psis/author/goethe") + (string= subj-1 "http://some.where/psis/persons/goethe")) + (is (string= pred-1 "http://some.where/base-psis/written")) + (is (or (string= obj-1 "http://some.where/psis/poem/zauberlehrling") + (string= obj-1 "http://some.where/psis/der_zauberlehrling"))) + (is (string= subj-2 "http://some.where/base-psis/poem")) + (is (string= pred-2 "http://psi.topicmaps.org/iso13250/model/instance")) + (is (or (string= obj-2 "http://some.where/psis/poem/zauberlehrling") + (string= obj-2 "http://some.where/psis/der_zauberlehrling")))) + ((string= subj-1 "http://some.where/base-psis/poem") + (is (string= pred-2 "http://some.where/base-psis/written")) + (is (or (string= obj-1 "http://some.where/psis/poem/zauberlehrling") + (string= obj-1 "http://some.where/psis/der_zauberlehrling"))) + (is (or (string= subj-2 "http://some.where/psis/author/goethe") + (string= subj-2 "http://some.where/psis/persons/goethe"))) + (is (string= pred-1 "http://psi.topicmaps.org/iso13250/model/type")) + (is (or (string= obj-2 "http://some.where/psis/poem/zauberlehrling") + (string= obj-2 "http://some.where/psis/der_zauberlehrling")))) + (t + (is-true nil)))) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (or (string= (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/psis/author/goethe") + (string= (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/psis/persons/goethe"))) + (is (string= (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/base-psis/first-name")) + (is (string= (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3)))) + "Johann Wolfgang")))))) + + +(test test-set-result-2 + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "PREFIX pref: + SELECT $subject $object WHERE { + ?subject pref:written ?object }") + (query-2 "BASE + SELECT $subject $object WHERE { + ?subject ?object }") + (query-3 "BASE + SELECT ?subject WHERE{ + ?subject + }") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) + (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) + (is-true q-obj-1) + (is (= (length (tm-sparql::select-group q-obj-1)) 1)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1)))) 4)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1)))) 4)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1)))) 4)) + (let* ((s-1 (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (s-2 (second (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (s-3 (third (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (s-4 (fourth (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (p-1 (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (p-2 (second (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (p-3 (third (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (p-4 (fourth (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (o-1 (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1))))) + (o-2 (second (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1))))) + (o-3 (third (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1))))) + (o-4 (fourth (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1)))))) + (is (string= p-1 "http://some.where/base-psis/written")) + (is (string= p-2 "http://some.where/base-psis/written")) + (is (string= p-3 "http://some.where/base-psis/written")) + (is (string= p-4 "http://some.where/base-psis/written")) + (is (or (not (set-exclusive-or + (list "http://some.where/psis/author/eichendorff" + "http://some.where/psis/author/schiller" + "http://some.where/psis/author/goethe") + (list s-1 s-2 s-3 s-4) + :test #'string=)) + (not (set-exclusive-or + (list "http://some.where/psis/author/eichendorff" + "http://some.where/psis/author/schiller" + "http://some.where/psis/persons/goethe") + (list s-1 s-2 s-3 s-4) + :test #'string=)))) + (is-false (set-exclusive-or + (list "http://some.where/psis/poem/mondnacht" + "http://some.where/psis/poem/resignation" + "http://some.where/psis/poem/erlkoenig" + "http://some.where/psis/poem/zauberlehrling") + (list o-1 o-2 o-3 o-4) + :test #'string=))) + (is-true q-obj-2) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2)))) 3)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2)))) 3)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2)))) 3)) + (let* ((s-1 (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (s-2 (second (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (s-3 (third (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (p-1 (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (p-2 (second (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (p-3 (third (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (o-1 (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2))))) + (o-2 (second (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2))))) + (o-3 (third (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2)))))) + (string= p-1 "http://some.where/base-psis/first-name") + (string= p-2 "http://some.where/base-psis/first-name") + (string= p-3 "http://some.where/base-psis/first-name") + (cond ((string= o-1 "Johann Christoph Friedrich") + (is (string= s-1 "http://some.where/psis/author/schiller")) + (cond ((string= o-2 "Johann Wolfgang") + (is (or (string= s-2 "http://some.where/psis/author/goethe") + (string= s-2 "http://some.where/psis/persons/goethe"))) + (is (string= s-3 "http://some.where/psis/author/eichendorff")) + (is (string= o-3 "Joseph Karl Benedikt"))) + ((string= o-2 "Joseph Karl Benedikt") + (is (string= s-2 "http://some.where/psis/author/eichendorff")) + (is (or (string= s-3 "http://some.where/psis/author/goethe") + (string= s-3 "http://some.where/psis/persons/goethe"))) + (is (string= o-3 "Johann Wolfgang"))) + (t + (is-true nil)))) + ((string= o-1 "Johann Wolfgang") + (is (or (string= s-1 "http://some.where/psis/author/goethe") + (string= s-1 "http://some.where/psis/persons/goethe"))) + (cond ((string= o-2 "Johann Christoph Friedrich") + (is (string= s-2 "http://some.where/psis/author/schiller")) + (is (string= s-3 "http://some.where/psis/author/eichendorff")) + (is (string= o-3 "Joseph Karl Benedikt"))) + ((string= o-2 "Joseph Karl Benedikt") + (is (string= s-2 "http://some.where/psis/author/eichendorff")) + (is (string= s-3 "http://some.where/psis/author/schiller")) + (is (string= o-3 "Johann Christoph Friedrich"))) + (t + (is-true nil)))) + ((string= o-1 "Joseph Karl Benedikt") + (is (string= s-1 "http://some.where/psis/author/eichendorff")) + (cond ((string= o-2 "Johann Wolfgang") + (is (or (string= s-2 "http://some.where/psis/author/goethe") + (string= s-2 "http://some.where/psis/persons/goethe"))) + (is (string= s-3 "http://some.where/psis/author/schiller")) + (is (string= o-3 "Johann Christoph Friedrich"))) + ((string= o-2 "Johann Christoph Friedrich") + (is (string= s-2 "http://some.where/psis/author/schiller")) + (is (or (string= s-3 "http://some.where/psis/author/goethe") + (string= s-3 "http://some.where/psis/persons/goethe"))) + (is (string= o-3 "Johann Wolfgang"))) + (t + (is-true nil)))) + (t + (is-true nil)))) + (is-true q-obj-3) + (is (= (length (tm-sparql::select-group q-obj-3)) 1)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (or (string= (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/psis/author/goethe") + (string= (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/psis/persons/goethe"))) + (is (string= (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/base-psis/written")) + (is (string= (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/psis/poem/zauberlehrling")))))) + + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))