[isidorus-cvs] r425 - in trunk/src: TM-SPARQL base-tools unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Apr 7 19:19:16 UTC 2011
Author: lgiessmann
Date: Thu Apr 7 15:19:16 2011
New Revision: 425
Log:
TM-SPARQL: fixed a bug in the function in-literal-string-p
Modified:
trunk/src/TM-SPARQL/filter_wrappers.lisp
trunk/src/TM-SPARQL/sparql.lisp
trunk/src/TM-SPARQL/sparql_filter.lisp
trunk/src/base-tools/base-tools.lisp
trunk/src/unit_tests/sparql_test.lisp
Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp (original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp Thu Apr 7 15:19:16 2011
@@ -187,10 +187,11 @@
(defun filter-functions::str(x)
- (if (stringp x)
- (if (and (base-tools:string-starts-with x "<")
- (base-tools:string-ends-with x ">")
- (base-tools:absolute-uri-p (subseq x 1 (1- (length x)))))
- (subseq x 1 (1- (length x)))
- x)
- (write-to-string x)))
\ No newline at end of file
+ ;(if (stringp x) ;TODO: remove
+ ;(if (and (base-tools:string-starts-with x "<")
+ ;(base-tools:string-ends-with x ">")
+ ;(base-tools:absolute-uri-p (subseq x 1 (1- (length x)))))
+ ;(subseq x 1 (1- (length x)))
+ ;x)
+ ;(write-to-string x)))
+ (write-to-string x))
\ No newline at end of file
Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp (original)
+++ trunk/src/TM-SPARQL/sparql.lisp Thu Apr 7 15:19:16 2011
@@ -368,38 +368,6 @@
(elt (getf results :result) idx)))))))))
-;(defun to-lisp-code (variable-values filter)
-; "Concatenates all variable names and elements with the filter expression
-; in a let statement and returns a string representing the corresponding
-; lisp code."
-; (declare (List variable-values))
-; (let ((result "")
-; (cleanup-str ""))
-; (dolist (var-elem variable-values)
-; (push-string
-; (concat "(defvar ?" (getf var-elem :variable-name) " "
-; (write-to-string (getf var-elem :variable-value)) ")")
-; result)
-; (push-string
-; (concat "(defvar $" (getf var-elem :variable-name) " "
-; (write-to-string (getf var-elem :variable-value)) ")")
-; result))
-; (push-string "(let* ((true t)(false nil)" result)
-; (push-string (concat "(result " filter "))") result)
-; (push-string "(declare (Ignorable true false " result)
-; (push-string "))" result)
-; (dolist (var-elem variable-values)
-; (push-string (concat "(makunbound '?" (getf var-elem :variable-name) ")")
-; cleanup-str)
-; (push-string (concat "(makunbound '$" (getf var-elem :variable-name) ")")
-; cleanup-str))
-; (push-string "(in-package :cl-user)" cleanup-str)
-; (push-string cleanup-str result)
-; (push-string "result)" result)
-; (concat "(handler-case (progn " result ") (condition () (progn " cleanup-str
-; "nil)))")))
-
-
(defun to-lisp-code (variable-values filter)
"Concatenates all variable names and elements with the filter expression
in a let statement and returns a string representing the corresponding
@@ -1409,22 +1377,24 @@
&key (back-as-string-when-unsupported nil))
"A helper function that casts the passed string value of the literal
corresponding to the passed literal-type."
- (declare (String literal-value literal-type)
+ (declare (String literal-value)
+ (type (or String null) literal-type)
(Boolean back-as-string-when-unsupported))
- (cond ((string= literal-type *xml-string*)
- literal-value)
- ((string= literal-type *xml-boolean*)
- (cast-literal-to-boolean literal-value))
- ((string= literal-type *xml-integer*)
- (cast-literal-to-integer literal-value))
- ((string= literal-type *xml-double*)
- (cast-literal-to-double literal-value))
- ((string= literal-type *xml-decimal*)
- (cast-literal-to-decimal literal-value))
- (t ; return the value as a string
- (if back-as-string-when-unsupported
- literal-value
- (concat "\"\"\"" literal-value "\"\"\"^^" literal-type)))))
+ (let ((local-literal-type (if literal-type literal-type *xml-string*)))
+ (cond ((string= local-literal-type *xml-string*)
+ literal-value)
+ ((string= local-literal-type *xml-boolean*)
+ (cast-literal-to-boolean literal-value))
+ ((string= local-literal-type *xml-integer*)
+ (cast-literal-to-integer literal-value))
+ ((string= local-literal-type *xml-double*)
+ (cast-literal-to-double literal-value))
+ ((string= local-literal-type *xml-decimal*)
+ (cast-literal-to-decimal literal-value))
+ (t ; return the value as a string
+ (if back-as-string-when-unsupported
+ literal-value
+ (concat "\"\"\"" literal-value "\"\"\"^^" local-literal-type))))))
(defun cast-literal-to-decimal (literal-value)
Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp (original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp Thu Apr 7 15:19:16 2011
@@ -350,12 +350,24 @@
(+ inner-value (1+ (length (name-after-paranthesis
(subseq left-string inner-value))))))))
(paranthesis-pair-idx
- (let* ((cleaned-str (trim-whitespace-right left-string))
- (bracket-scope (reverse-bracket-scope cleaned-str)))
- (when bracket-scope
- (- (- (length left-string)
- (- (length left-string) (length cleaned-str)))
- (length bracket-scope)))))
+ (let ((value
+ (let* ((cleaned-str (trim-whitespace-right left-string))
+ (bracket-scope (reverse-bracket-scope cleaned-str)))
+ (when bracket-scope
+ (- (- (length left-string)
+ (- (length left-string) (length cleaned-str)))
+ (length bracket-scope))))))
+ (when value ;search a functionname: FUN(...)
+ (let* ((str-before (subseq left-string 0 value))
+ (c-str-before (trim-whitespace-right str-before)))
+ (if (string-ends-with-one-of c-str-before *supported-functions*)
+ (loop for fun-name in *supported-functions*
+ when (string-ends-with c-str-before fun-name)
+ return (- value
+ (+ (- (length str-before)
+ (length c-str-before))
+ (length fun-name))))
+ value)))))
(start-idx (or first-bracket paranthesis-pair-idx 0)))
(subseq left-string start-idx)))
Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp (original)
+++ trunk/src/base-tools/base-tools.lisp Thu Apr 7 15:19:16 2011
@@ -352,12 +352,8 @@
(search-first (list "\"" "'") (subseq main-string 0 first-pos)
:from-end from-end))
(next-str
- (if from-end
-
-
+ (if from-end
(subseq main-string 0 literal-start)
-
-
(let* ((sub-str (subseq main-string literal-start))
(literal-result (get-literal sub-str)))
(getf literal-result :next-string)))))
@@ -441,31 +437,25 @@
(let ((result nil))
(dotimes (idx (length filter-string) result)
(let* ((current-str (subseq filter-string idx))
- (delimiter (cond ((string-starts-with current-str "'''")
- "'''")
- ((string-starts-with current-str "'")
- "'")
- ((string-starts-with current-str "\"\"\"")
- "\"\"\"")
- ((string-starts-with current-str "\"")
- "\""))))
+ (delimiter (get-literal-quotation current-str)))
(when delimiter
(let* ((end-pos
(let ((result
- (search-first (list delimiter)
- (subseq current-str (length delimiter)))))
- (when result
+ (find-literal-end (subseq current-str (length delimiter))
+ delimiter)))
+ (when result
(+ (length delimiter) result))))
(quoted-str (when end-pos
(subseq current-str (length delimiter) end-pos)))
(start-pos idx))
- (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))
- (if (and (>= pos start-pos)
- (<= pos (+ start-pos end-pos)))
- (progn
- (setf result t)
- (setf idx (length filter-string)))
- (incf idx (+ (* 2 (length delimiter)) (length quoted-str))))))))))
+ (when quoted-str
+ (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))
+ (if (and (>= pos start-pos)
+ (< pos (+ start-pos end-pos)))
+ (progn
+ (setf result t)
+ (setf idx (length filter-string)))
+ (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))))))))))
(defun search-first-unclosed-paranthesis (str &key (ignore-literals t))
Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp (original)
+++ trunk/src/unit_tests/sparql_test.lisp Thu Apr 7 15:19:16 2011
@@ -1549,7 +1549,7 @@
"BASE <http://some.where/psis/poem/>
SELECT $subject ?predicate WHERE{
?subject $predicate <zauberlehrling> .
- FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}")
+ FILTER (STR(?predicate) = '\"<http://some.where/base-psis/written>\"')}")
(query-2 "SELECT ?object ?subject WHERE{
<http://some.where/psis/author/goethe> ?predicate ?object .
FILTER (isLITERAL(?object) &&
@@ -2408,7 +2408,9 @@
FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82
FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1
FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'
- FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1)"
+ FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1)
+ FILTER (DATATYPE(?obj1) = '" *xml-string* "' || DATATYPE(?obj1) = '" *xml-integer* "') && !(DATATYPE(?obj1) = '" *xml-double* "')
+ FILTER STR(?obj1) = '82' || ?obj1='von Goethe'"
"}"))
(r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
;(is-true (= (length r-1) 2))
More information about the Isidorus-cvs
mailing list