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 <iri> 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 <url> => 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 + + ;; <full-url> + ;; <base-suffix> + ;; 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: <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 + 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))