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. <prefix-value>. 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: <uri-prefix>)|(PREFIX : <uri-prefix>)* +;(BASE <base-uri>)*)* +;SELECT ?varName+ +;WHERE { +;(({?subjectOrVarName predicateOrVarName objectOrVarName}?)* +;({?FILTER (filterExpression)}?)* +;(BASE <base-uri>)*)* +;} +;Grouping +;{} +;Base +;BASE <uri> +;… +;<book> +;-> 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