| 1 | ;;+----------------------------------------------------------------------------- |
|---|
| 2 | ;;+ Isidorus |
|---|
| 3 | ;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff |
|---|
| 4 | ;;+ |
|---|
| 5 | ;;+ Isidorus is freely distributable under the LLGPL license. |
|---|
| 6 | ;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and |
|---|
| 7 | ;;+ trunk/docs/LGPL-LICENSE.txt. |
|---|
| 8 | ;;+----------------------------------------------------------------------------- |
|---|
| 9 | |
|---|
| 10 | (in-package :TM-SPARQL) |
|---|
| 11 | |
|---|
| 12 | |
|---|
| 13 | (defparameter *supported-functions* |
|---|
| 14 | (list "BOUND" "isLITERAL" "STR" "DATATYPE" "REGEX") |
|---|
| 15 | "Contains all supported SPARQL-functions") |
|---|
| 16 | |
|---|
| 17 | |
|---|
| 18 | (defparameter *supported-primary-arithmetic-operators* |
|---|
| 19 | (list "*" "/") "Contains all supported arithmetic operators.") |
|---|
| 20 | |
|---|
| 21 | |
|---|
| 22 | (defparameter *supported-secundary-arithmetic-operators* |
|---|
| 23 | (list "+" "-") "Contains all supported arithmetic operators.") |
|---|
| 24 | |
|---|
| 25 | |
|---|
| 26 | (defparameter *supported-compare-operators* |
|---|
| 27 | (list "!=" "<=" ">=" "=" "<" ">") ;note the order is important! |
|---|
| 28 | ;the operators with length = 2 |
|---|
| 29 | ;must be listed first |
|---|
| 30 | "Contains all supported binary operators.") |
|---|
| 31 | |
|---|
| 32 | |
|---|
| 33 | (defparameter *supported-join-operators* |
|---|
| 34 | (list "||" "&&") "Contains all supported join operators.") |
|---|
| 35 | |
|---|
| 36 | |
|---|
| 37 | (defparameter *supported-unary-operators* |
|---|
| 38 | (list "!" "+" "-") "Contains all supported unary operators") |
|---|
| 39 | |
|---|
| 40 | |
|---|
| 41 | (defparameter *allowed-filter-calls* |
|---|
| 42 | (append (list "one+" "one-" "progn" "or" "and" "not" "!=" "=" |
|---|
| 43 | ">" ">=" "<" "<=" "+" "-" "*" "/") |
|---|
| 44 | *supported-functions*)) |
|---|
| 45 | |
|---|
| 46 | |
|---|
| 47 | (defun *2-compare-operators* () |
|---|
| 48 | (remove-null |
|---|
| 49 | (map 'list #'(lambda(op) |
|---|
| 50 | (when (= (length op) 2) |
|---|
| 51 | op)) |
|---|
| 52 | *supported-compare-operators*))) |
|---|
| 53 | |
|---|
| 54 | |
|---|
| 55 | (defun *1-compare-operators* () |
|---|
| 56 | (remove-null |
|---|
| 57 | (map 'list #'(lambda(op) |
|---|
| 58 | (when (= (length op) 1) |
|---|
| 59 | op)) |
|---|
| 60 | *supported-compare-operators*))) |
|---|
| 61 | |
|---|
| 62 | |
|---|
| 63 | (defun *supported-arithmetic-operators* () |
|---|
| 64 | (append *supported-primary-arithmetic-operators* |
|---|
| 65 | *supported-secundary-arithmetic-operators*)) |
|---|
| 66 | |
|---|
| 67 | |
|---|
| 68 | (defun *supported-binary-operators* () |
|---|
| 69 | (append (*supported-arithmetic-operators*) |
|---|
| 70 | *supported-compare-operators* |
|---|
| 71 | *supported-join-operators*)) |
|---|
| 72 | |
|---|
| 73 | |
|---|
| 74 | (defun *supported-operators* () |
|---|
| 75 | (union (*supported-binary-operators*) *supported-unary-operators* |
|---|
| 76 | :test #'string=)) |
|---|
| 77 | |
|---|
| 78 | |
|---|
| 79 | (defparameter *supported-brackets* |
|---|
| 80 | (list "(" ")") |
|---|
| 81 | "Contains all supported brackets in a list of strings.") |
|---|
| 82 | |
|---|
| 83 | |
|---|
| 84 | (defun make-sparql-parser-condition(rest-of-query entire-query expected) |
|---|
| 85 | "Creates a spqrql-parser-error object." |
|---|
| 86 | (declare (String rest-of-query entire-query expected)) |
|---|
| 87 | (let ((message |
|---|
| 88 | (format nil "The query:~%\"~a\"~%~%has a bad token at position ~a => ~a.~%Expected: ~a" |
|---|
| 89 | entire-query (- (length entire-query) |
|---|
| 90 | (length rest-of-query)) |
|---|
| 91 | (subseq entire-query (- (length entire-query) |
|---|
| 92 | (length rest-of-query))) |
|---|
| 93 | expected))) |
|---|
| 94 | (make-condition 'sparql-parser-error :message message))) |
|---|
| 95 | |
|---|
| 96 | |
|---|
| 97 | (defgeneric parse-filter (construct query-string) |
|---|
| 98 | (:documentation "A helper functions that returns a filter and the next-query |
|---|
| 99 | string in the form (:next-query string |
|---|
| 100 | :filter-string object).") |
|---|
| 101 | (:method ((construct SPARQL-Query) (query-string String)) |
|---|
| 102 | ;note the order of the invacations is important! |
|---|
| 103 | (let* ((result-set-boundings (set-boundings construct query-string)) |
|---|
| 104 | (filter-string (getf result-set-boundings :filter-string)) |
|---|
| 105 | (next-query (getf result-set-boundings :next-query)) |
|---|
| 106 | (original-filter-string |
|---|
| 107 | (subseq query-string 0 (- (length query-string) |
|---|
| 108 | (length next-query)))) |
|---|
| 109 | (filter-string-casted-constants |
|---|
| 110 | (cast-literal-constants construct filter-string)) |
|---|
| 111 | (filter-string-unary-ops |
|---|
| 112 | (set-unary-operators construct filter-string-casted-constants)) |
|---|
| 113 | (filter-string-or-and-ops |
|---|
| 114 | (set-or-and-operators construct filter-string-unary-ops |
|---|
| 115 | original-filter-string)) |
|---|
| 116 | (filter-string-arithmetic-ops |
|---|
| 117 | (set-arithmetic-operators construct filter-string-or-and-ops)) |
|---|
| 118 | (filter-string-compare-ops |
|---|
| 119 | (set-compare-operators construct filter-string-arithmetic-ops)) |
|---|
| 120 | (filter-string-functions |
|---|
| 121 | (set-functions construct filter-string-compare-ops))) |
|---|
| 122 | (add-filter construct |
|---|
| 123 | (scan-filter-for-deprecated-calls |
|---|
| 124 | construct filter-string-functions filter-string)) |
|---|
| 125 | (parse-group construct next-query)))) |
|---|
| 126 | |
|---|
| 127 | |
|---|
| 128 | (defgeneric cast-literal-constants (construct filter-string) |
|---|
| 129 | (:documentation "Casts all constants of the form 'string-value'^^datatype to an |
|---|
| 130 | object of the specified type. If the specified type is not |
|---|
| 131 | supported the return value is the string-value without a |
|---|
| 132 | type specifier.") |
|---|
| 133 | (:method ((construct SPARQL-Query) (filter-string String)) |
|---|
| 134 | (let ((first-pos (search-first (list "'" "\"") filter-string))) |
|---|
| 135 | (if (not first-pos) |
|---|
| 136 | filter-string |
|---|
| 137 | (let* ((delimiters |
|---|
| 138 | (append (white-space) *supported-brackets* (list "}"))) |
|---|
| 139 | (result (get-literal (subseq filter-string first-pos))) |
|---|
| 140 | (literal-value (getf result :literal)) |
|---|
| 141 | (next-string (getf result :next-string)) |
|---|
| 142 | (lang |
|---|
| 143 | (when (string-starts-with next-string "@") |
|---|
| 144 | (let ((end-pos (search-first delimiters next-string))) |
|---|
| 145 | (when end-pos |
|---|
| 146 | (subseq next-string 0 end-pos))))) |
|---|
| 147 | (type |
|---|
| 148 | (when (string-starts-with next-string "^^") |
|---|
| 149 | (let ((end-pos |
|---|
| 150 | (let ((pos (search-first delimiters next-string))) |
|---|
| 151 | (if pos |
|---|
| 152 | pos |
|---|
| 153 | (length next-string))))) |
|---|
| 154 | (when end-pos |
|---|
| 155 | (subseq next-string 2 end-pos))))) |
|---|
| 156 | (modified-literal-value |
|---|
| 157 | (if type |
|---|
| 158 | (if (> (length literal-value) 0) |
|---|
| 159 | (string-trim (list (elt literal-value 0)) literal-value) |
|---|
| 160 | literal-value) |
|---|
| 161 | literal-value))) |
|---|
| 162 | (concat (subseq filter-string 0 first-pos) |
|---|
| 163 | (if type |
|---|
| 164 | (write-to-string |
|---|
| 165 | (cast-literal modified-literal-value type |
|---|
| 166 | :back-as-string-when-unsupported t)) |
|---|
| 167 | modified-literal-value) |
|---|
| 168 | (cast-literal-constants |
|---|
| 169 | construct |
|---|
| 170 | (subseq next-string (cond (lang (length lang)) |
|---|
| 171 | (type (+ 2 (length type))) |
|---|
| 172 | (t 0)))))))))) |
|---|
| 173 | |
|---|
| 174 | |
|---|
| 175 | (defgeneric scan-filter-for-deprecated-calls (construct filter-string |
|---|
| 176 | original-filter) |
|---|
| 177 | (:documentation "Returns the passed filter-string where all functions |
|---|
| 178 | are explicit wrapped in the filter-functions package |
|---|
| 179 | or throws a sparql-parser-error of there is an |
|---|
| 180 | unallowed function call.") |
|---|
| 181 | (:method ((construct SPARQL-Query) (filter-string String) |
|---|
| 182 | (original-filter String)) |
|---|
| 183 | (let ((result "")) |
|---|
| 184 | (dotimes (idx (length filter-string) result) |
|---|
| 185 | (let ((fun-name (return-function-name (subseq filter-string idx)))) |
|---|
| 186 | (cond ((not fun-name) |
|---|
| 187 | (push-string (subseq filter-string idx (1+ idx)) result)) |
|---|
| 188 | ((string-starts-with-one-of fun-name *allowed-filter-calls*) |
|---|
| 189 | (push-string "(filter-functions::" result) |
|---|
| 190 | (push-string fun-name result) |
|---|
| 191 | (incf idx (length fun-name))) |
|---|
| 192 | (t |
|---|
| 193 | (error |
|---|
| 194 | (make-condition |
|---|
| 195 | 'exceptions:sparql-parser-error |
|---|
| 196 | :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the deprecated function ~a!" |
|---|
| 197 | filter-string original-filter fun-name)))))))))) |
|---|
| 198 | |
|---|
| 199 | |
|---|
| 200 | (defun return-function-name (filter-string) |
|---|
| 201 | "If the string starts with ( there is returned the function name |
|---|
| 202 | that is placed directly after the (." |
|---|
| 203 | (declare (String filter-string)) |
|---|
| 204 | (when (string-starts-with filter-string "(") |
|---|
| 205 | (let ((local-str (trim-whitespace-left (subseq filter-string 1))) |
|---|
| 206 | (whitespaces (map 'list #'string (white-space))) |
|---|
| 207 | (result "")) |
|---|
| 208 | (dotimes (idx (length local-str) result) |
|---|
| 209 | (let ((current-char (subseq local-str idx (1+ idx)))) |
|---|
| 210 | (if (string-starts-with-one-of |
|---|
| 211 | current-char (append whitespaces *supported-brackets*)) |
|---|
| 212 | (setf idx (length local-str)) |
|---|
| 213 | (push-string current-char result))))))) |
|---|
| 214 | |
|---|
| 215 | |
|---|
| 216 | (defgeneric set-functions (construct filter-string) |
|---|
| 217 | (:documentation "Transforms all supported functions of the form |
|---|
| 218 | function(x, y) to (function x y).") |
|---|
| 219 | (:method ((construct SPARQL-Query) (filter-string String)) |
|---|
| 220 | (let ((op-pos (find-functions filter-string))) |
|---|
| 221 | (if (not op-pos) |
|---|
| 222 | filter-string |
|---|
| 223 | (let* ((fun-name |
|---|
| 224 | (return-if-starts-with (subseq filter-string op-pos) |
|---|
| 225 | *supported-functions*)) |
|---|
| 226 | (left-str (subseq filter-string 0 op-pos)) |
|---|
| 227 | (right-str (subseq filter-string |
|---|
| 228 | (+ op-pos (length fun-name)))) |
|---|
| 229 | (cleaned-right-str (trim-whitespace-left right-str)) |
|---|
| 230 | (arg-list (bracket-scope cleaned-right-str)) |
|---|
| 231 | (cleaned-arg-list (clean-function-arguments arg-list)) |
|---|
| 232 | (modified-str |
|---|
| 233 | (let ((modified-arg-list |
|---|
| 234 | (if (string= fun-name "BOUND") |
|---|
| 235 | (let* ((var-start |
|---|
| 236 | (search-first (list "?" "$") cleaned-arg-list)) |
|---|
| 237 | (var-end |
|---|
| 238 | (let ((val |
|---|
| 239 | (when var-start |
|---|
| 240 | (search-first |
|---|
| 241 | (list ")") |
|---|
| 242 | (subseq cleaned-arg-list var-start))))) |
|---|
| 243 | (if val |
|---|
| 244 | val |
|---|
| 245 | (length (subseq cleaned-arg-list var-start)))))) |
|---|
| 246 | (when (and var-start var-end) |
|---|
| 247 | (concat (subseq cleaned-arg-list 0 var-start) |
|---|
| 248 | "\"" (subseq cleaned-arg-list var-start |
|---|
| 249 | (+ var-start var-end)) |
|---|
| 250 | "\"" (subseq cleaned-arg-list |
|---|
| 251 | (+ var-start var-end))))) |
|---|
| 252 | cleaned-arg-list))) |
|---|
| 253 | (concat |
|---|
| 254 | left-str "(" fun-name " " modified-arg-list ")" |
|---|
| 255 | (subseq right-str (+ (- (length right-str) |
|---|
| 256 | (length cleaned-right-str)) |
|---|
| 257 | (length arg-list))))))) |
|---|
| 258 | (set-functions construct modified-str)))))) |
|---|
| 259 | |
|---|
| 260 | |
|---|
| 261 | (defun clean-function-arguments (argument-string) |
|---|
| 262 | "Transforms all arguments within an argument list of the form |
|---|
| 263 | (x, y, z, ...) to x y z." |
|---|
| 264 | (declare (String argument-string)) |
|---|
| 265 | (when (and (string-starts-with argument-string "(") |
|---|
| 266 | (string-ends-with argument-string ")")) |
|---|
| 267 | (let ((local-str (subseq argument-string 1 (1- (length argument-string)))) |
|---|
| 268 | (result "")) |
|---|
| 269 | (dotimes (idx (length local-str) result) |
|---|
| 270 | (let ((current-char (subseq local-str idx (1+ idx)))) |
|---|
| 271 | (if (and (string= current-char ",") |
|---|
| 272 | (not (in-literal-string-p local-str idx))) |
|---|
| 273 | (push-string " " result) |
|---|
| 274 | (push-string current-char result))))))) |
|---|
| 275 | |
|---|
| 276 | |
|---|
| 277 | (defun find-functions (filter-string) |
|---|
| 278 | "Returns the idx of the first found 'BOUND', 'isLITERAL', 'STR', |
|---|
| 279 | 'DATATYPE', or 'REGEX'. |
|---|
| 280 | It must not be in a literal string or directly after a (." |
|---|
| 281 | (declare (String filter-string)) |
|---|
| 282 | (let* ((first-pos |
|---|
| 283 | (search-first-ignore-literals *supported-functions* |
|---|
| 284 | filter-string))) |
|---|
| 285 | (when first-pos |
|---|
| 286 | (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos)))) |
|---|
| 287 | (if (not (string-ends-with left-part "(")) |
|---|
| 288 | first-pos |
|---|
| 289 | (let ((next-pos |
|---|
| 290 | (find-functions (subseq filter-string (1+ first-pos))))) |
|---|
| 291 | (when next-pos |
|---|
| 292 | (+ 1 first-pos next-pos)))))))) |
|---|
| 293 | |
|---|
| 294 | |
|---|
| 295 | (defgeneric set-compare-operators (construct filter-string) |
|---|
| 296 | (:documentation "Transforms the =, !=, <, >, <= and >= operators in the |
|---|
| 297 | filter string to the the corresponding lisp functions.") |
|---|
| 298 | (:method ((construct SPARQL-Query) (filter-string String)) |
|---|
| 299 | (let ((op-pos (find-compare-operators filter-string))) |
|---|
| 300 | (if (not op-pos) |
|---|
| 301 | filter-string |
|---|
| 302 | (let* ((op-str (if (string-starts-with-one-of |
|---|
| 303 | (subseq filter-string op-pos) |
|---|
| 304 | (*2-compare-operators*)) |
|---|
| 305 | (subseq filter-string op-pos (+ 2 op-pos)) |
|---|
| 306 | (subseq filter-string op-pos (1+ op-pos)))) |
|---|
| 307 | (left-str (subseq filter-string 0 op-pos)) |
|---|
| 308 | (right-str (subseq filter-string (+ (length op-str) op-pos))) |
|---|
| 309 | (left-scope (find-compare-left-scope left-str)) |
|---|
| 310 | (right-scope (find-compare-right-scope right-str)) |
|---|
| 311 | (modified-str |
|---|
| 312 | (concat (subseq left-str 0 (- (length left-str) |
|---|
| 313 | (length left-scope))) |
|---|
| 314 | "(" op-str " " left-scope " " right-scope ")" |
|---|
| 315 | (subseq right-str (length right-scope))))) |
|---|
| 316 | (set-compare-operators construct modified-str)))))) |
|---|
| 317 | |
|---|
| 318 | |
|---|
| 319 | (defun find-compare-operators (filter-string) |
|---|
| 320 | "Returns the idx of the first found =, !=, <, >, <= or >= operator. |
|---|
| 321 | It must not be in a literal string or directly after a (." |
|---|
| 322 | (declare (String filter-string)) |
|---|
| 323 | (let* ((first-pos |
|---|
| 324 | (search-first-ignore-literals *supported-compare-operators* |
|---|
| 325 | filter-string)) |
|---|
| 326 | (delta (if first-pos |
|---|
| 327 | (if (string-starts-with-one-of |
|---|
| 328 | (subseq filter-string first-pos) |
|---|
| 329 | (*2-compare-operators*)) |
|---|
| 330 | 2 |
|---|
| 331 | 1) |
|---|
| 332 | 1))) |
|---|
| 333 | (when first-pos |
|---|
| 334 | (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos)))) |
|---|
| 335 | (if (not (string-ends-with-one-of |
|---|
| 336 | left-part (append (*1-compare-operators*) (list "(")))) |
|---|
| 337 | first-pos |
|---|
| 338 | (let ((next-pos |
|---|
| 339 | (find-compare-operators (subseq filter-string (+ delta first-pos))))) |
|---|
| 340 | (when next-pos |
|---|
| 341 | (+ delta first-pos next-pos)))))))) |
|---|
| 342 | |
|---|
| 343 | |
|---|
| 344 | (defun find-compare-left-scope (left-string) |
|---|
| 345 | "Returns the string that is the left part of the binary scope." |
|---|
| 346 | (declare (String left-string)) |
|---|
| 347 | (let* ((first-bracket |
|---|
| 348 | (let ((inner-value (search-first-unclosed-paranthesis left-string))) |
|---|
| 349 | (when inner-value |
|---|
| 350 | (+ inner-value (1+ (length (name-after-paranthesis |
|---|
| 351 | (subseq left-string inner-value)))))))) |
|---|
| 352 | (paranthesis-pair-idx |
|---|
| 353 | (let ((value |
|---|
| 354 | (let* ((cleaned-str (trim-whitespace-right left-string)) |
|---|
| 355 | (bracket-scope (reverse-bracket-scope cleaned-str))) |
|---|
| 356 | (when bracket-scope |
|---|
| 357 | (- (- (length left-string) |
|---|
| 358 | (- (length left-string) (length cleaned-str))) |
|---|
| 359 | (length bracket-scope)))))) |
|---|
| 360 | (when value ;search a functionname: FUN(...) |
|---|
| 361 | (let* ((str-before (subseq left-string 0 value)) |
|---|
| 362 | (c-str-before (trim-whitespace-right str-before))) |
|---|
| 363 | (if (string-ends-with-one-of c-str-before *supported-functions*) |
|---|
| 364 | (loop for fun-name in *supported-functions* |
|---|
| 365 | when (string-ends-with c-str-before fun-name) |
|---|
| 366 | return (- value |
|---|
| 367 | (+ (- (length str-before) |
|---|
| 368 | (length c-str-before)) |
|---|
| 369 | (length fun-name)))) |
|---|
| 370 | value))))) |
|---|
| 371 | (start-idx (or first-bracket paranthesis-pair-idx 0))) |
|---|
| 372 | (subseq left-string start-idx))) |
|---|
| 373 | |
|---|
| 374 | |
|---|
| 375 | (defun find-compare-right-scope (right-string) |
|---|
| 376 | "Returns the string that is the right part of the binary scope." |
|---|
| 377 | (declare (String right-string)) |
|---|
| 378 | (let* ((first-pos |
|---|
| 379 | (search-first-ignore-literals *supported-compare-operators* |
|---|
| 380 | right-string)) |
|---|
| 381 | (first-bracket |
|---|
| 382 | (let ((inner-value (search-first-unopened-paranthesis right-string))) |
|---|
| 383 | (when inner-value (1+ inner-value)))) |
|---|
| 384 | (paranthesis-pair-idx |
|---|
| 385 | (let* ((cleaned-str (trim-whitespace-left right-string)) |
|---|
| 386 | (bracket-scope (bracket-scope cleaned-str))) |
|---|
| 387 | (when bracket-scope |
|---|
| 388 | (+ (- (length right-string) (length cleaned-str)) |
|---|
| 389 | (length bracket-scope))))) |
|---|
| 390 | (end-idx (cond (paranthesis-pair-idx |
|---|
| 391 | paranthesis-pair-idx) |
|---|
| 392 | ((and first-pos first-bracket) |
|---|
| 393 | (min first-pos first-bracket)) |
|---|
| 394 | (first-pos first-pos) |
|---|
| 395 | (first-bracket first-bracket) |
|---|
| 396 | (t (if (= (length right-string) 0) |
|---|
| 397 | 0 |
|---|
| 398 | (length right-string)))))) |
|---|
| 399 | (subseq right-string 0 end-idx))) |
|---|
| 400 | |
|---|
| 401 | |
|---|
| 402 | (defgeneric set-arithmetic-operators (construct filter-string) |
|---|
| 403 | (:documentation "Transforms the +, -, *, / operators in the filter |
|---|
| 404 | string to the the corresponding lisp functions.") |
|---|
| 405 | (:method ((construct SPARQL-Query) (filter-string String)) |
|---|
| 406 | (let ((filter-string-*/ (set-*-and-/-operators construct filter-string))) |
|---|
| 407 | (set-+-and---operators construct filter-string-*/)))) |
|---|
| 408 | |
|---|
| 409 | |
|---|
| 410 | (defun find-*/-operators (filter-string) |
|---|
| 411 | "Returns the idx of the first found * or / operator. |
|---|
| 412 | It must not be in a literal string or directly after a (." |
|---|
| 413 | (declare (String filter-string)) |
|---|
| 414 | (let ((first-pos |
|---|
| 415 | (search-first-ignore-literals *supported-primary-arithmetic-operators* |
|---|
| 416 | filter-string))) |
|---|
| 417 | (when first-pos |
|---|
| 418 | (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos)))) |
|---|
| 419 | (if (not (string-ends-with left-part "(")) |
|---|
| 420 | first-pos |
|---|
| 421 | (let ((next-pos |
|---|
| 422 | (find-*/-operators (subseq filter-string (1+ first-pos))))) |
|---|
| 423 | (when next-pos |
|---|
| 424 | (+ 1 first-pos next-pos)))))))) |
|---|
| 425 | |
|---|
| 426 | |
|---|
| 427 | (defgeneric set-*-and-/-operators (construct filter-string) |
|---|
| 428 | (:documentation "Transforms the *, / operators in the filter |
|---|
| 429 | string to the the corresponding lisp functions.") |
|---|
| 430 | (:method ((construct SPARQL-Query) (filter-string String)) |
|---|
| 431 | (let ((op-pos (find-*/-operators filter-string))) |
|---|
| 432 | (if (not op-pos) |
|---|
| 433 | filter-string |
|---|
| 434 | (let* ((op-str (subseq filter-string op-pos (1+ op-pos))) |
|---|
| 435 | (left-str (subseq filter-string 0 op-pos)) |
|---|
| 436 | (right-str (subseq filter-string (1+ op-pos))) |
|---|
| 437 | (left-scope (find-*/-left-scope left-str)) |
|---|
| 438 | (right-scope (find-*/-right-scope right-str)) |
|---|
| 439 | (modified-str |
|---|
| 440 | (concat |
|---|
| 441 | (subseq left-str 0 (- (length left-str) |
|---|
| 442 | (length left-scope))) |
|---|
| 443 | "(" op-str " " left-scope " " right-scope ")" |
|---|
| 444 | (subseq right-str (length right-scope))))) |
|---|
| 445 | (set-*-and-/-operators construct modified-str)))))) |
|---|
| 446 | |
|---|
| 447 | |
|---|
| 448 | (defun find-*/-left-scope (left-string) |
|---|
| 449 | "Returns the string that is the left part of the binary scope." |
|---|
| 450 | (declare (String left-string)) |
|---|
| 451 | (let* ((first-bracket |
|---|
| 452 | (let ((inner-value (search-first-unclosed-paranthesis left-string))) |
|---|
| 453 | (when inner-value |
|---|
| 454 | (+ inner-value (1+ (length (name-after-paranthesis |
|---|
| 455 | (subseq left-string inner-value)))))))) |
|---|
| 456 | (other-anchor |
|---|
| 457 | (let ((inner-value |
|---|
| 458 | (search-first-ignore-literals |
|---|
| 459 | (append *supported-secundary-arithmetic-operators* |
|---|
| 460 | *supported-compare-operators*) |
|---|
| 461 | left-string :from-end t))) |
|---|
| 462 | (when inner-value |
|---|
| 463 | (1+ inner-value)))) |
|---|
| 464 | (paranthesis-pair-idx |
|---|
| 465 | (let* ((cleaned-str (trim-whitespace-right left-string)) |
|---|
| 466 | (bracket-scope (reverse-bracket-scope cleaned-str))) |
|---|
| 467 | (when bracket-scope |
|---|
| 468 | (- (- (length left-string) |
|---|
| 469 | (- (length left-string) (length cleaned-str))) |
|---|
| 470 | (length bracket-scope))))) |
|---|
| 471 | (start-idx (cond (paranthesis-pair-idx |
|---|
| 472 | paranthesis-pair-idx) |
|---|
| 473 | ((and first-bracket other-anchor) |
|---|
| 474 | (max first-bracket other-anchor)) |
|---|
| 475 | ((or first-bracket other-anchor) |
|---|
| 476 | (or first-bracket other-anchor)) |
|---|
| 477 | (t 0)))) |
|---|
| 478 | (subseq left-string start-idx))) |
|---|
| 479 | |
|---|
| 480 | |
|---|
| 481 | (defun find-*/-right-scope (right-string) |
|---|
| 482 | "Returns the string that is the right part of the binary scope." |
|---|
| 483 | (declare (String right-string)) |
|---|
| 484 | (let* ((first-pos (search-first-ignore-literals |
|---|
| 485 | (append (*supported-arithmetic-operators*) |
|---|
| 486 | *supported-compare-operators*) |
|---|
| 487 | right-string)) |
|---|
| 488 | (first-bracket |
|---|
| 489 | (let ((inner-value (search-first-unopened-paranthesis right-string))) |
|---|
| 490 | (when inner-value (1+ inner-value)))) |
|---|
| 491 | (paranthesis-pair-idx |
|---|
| 492 | (let* ((cleaned-str (trim-whitespace-left right-string)) |
|---|
| 493 | (bracket-scope (bracket-scope cleaned-str))) |
|---|
| 494 | (when bracket-scope |
|---|
| 495 | (+ (- (length right-string) (length cleaned-str)) |
|---|
| 496 | (length bracket-scope))))) |
|---|
| 497 | (end-idx (cond (paranthesis-pair-idx |
|---|
| 498 | paranthesis-pair-idx) |
|---|
| 499 | ((and first-pos first-bracket) |
|---|
| 500 | (min first-pos first-bracket)) |
|---|
| 501 | (first-pos first-pos) |
|---|
| 502 | (first-bracket first-bracket) |
|---|
| 503 | (t (if (= (length right-string) 0) |
|---|
| 504 | (1- (length right-string))))))) |
|---|
| 505 | (subseq right-string 0 end-idx))) |
|---|
| 506 | |
|---|
| 507 | |
|---|
| 508 | (defgeneric set-+-and---operators (construct filter-string) |
|---|
| 509 | (:documentation "Transforms the +, - operators in the filter |
|---|
| 510 | string to the the corresponding lisp functions.") |
|---|
| 511 | (:method ((construct SPARQL-Query) (filter-string String)) |
|---|
| 512 | (let ((op-pos (find-+--operators filter-string))) |
|---|
| 513 | (if (not op-pos) |
|---|
| 514 | filter-string |
|---|
| 515 | (let* ((op-str (subseq filter-string op-pos (1+ op-pos))) |
|---|
| 516 | (left-str (subseq filter-string 0 op-pos)) |
|---|
| 517 | (right-str (subseq filter-string (1+ op-pos))) |
|---|
| 518 | (left-scope (find-+--left-scope left-str)) |
|---|
| 519 | (right-scope (find-+--right-scope right-str)) |
|---|
| 520 | (modified-str |
|---|
| 521 | (concat (subseq left-str 0 (- (length left-str) |
|---|
| 522 | (length left-scope))) |
|---|
| 523 | "(" op-str " " left-scope " " right-scope ")" |
|---|
| 524 | (subseq right-str (length right-scope))))) |
|---|
| 525 | (set-+-and---operators construct modified-str)))))) |
|---|
| 526 | |
|---|
| 527 | |
|---|
| 528 | (defun find-+--left-scope (left-string) |
|---|
| 529 | "Returns the string that is the left part of the binary scope." |
|---|
| 530 | (declare (String left-string)) |
|---|
| 531 | (let* ((first-bracket |
|---|
| 532 | (let ((inner-value (search-first-unclosed-paranthesis left-string))) |
|---|
| 533 | (when inner-value |
|---|
| 534 | (+ inner-value (1+ (length (name-after-paranthesis |
|---|
| 535 | (subseq left-string inner-value)))))))) |
|---|
| 536 | (other-anchor |
|---|
| 537 | (let ((inner-value |
|---|
| 538 | (search-first-ignore-literals *supported-compare-operators* |
|---|
| 539 | left-string :from-end t))) |
|---|
| 540 | (when inner-value |
|---|
| 541 | (1+ inner-value)))) |
|---|
| 542 | (paranthesis-pair-idx |
|---|
| 543 | (let* ((cleaned-str (trim-whitespace-right left-string)) |
|---|
| 544 | (bracket-scope (reverse-bracket-scope cleaned-str))) |
|---|
| 545 | (when bracket-scope |
|---|
| 546 | (- (- (length left-string) |
|---|
| 547 | (- (length left-string) (length cleaned-str))) |
|---|
| 548 | (length bracket-scope))))) |
|---|
| 549 | (start-idx (cond (paranthesis-pair-idx |
|---|
| 550 | paranthesis-pair-idx) |
|---|
| 551 | ((and first-bracket other-anchor) |
|---|
| 552 | (max first-bracket other-anchor)) |
|---|
| 553 | ((or first-bracket other-anchor) |
|---|
| 554 | (or first-bracket other-anchor)) |
|---|
| 555 | (t 0)))) |
|---|
| 556 | (subseq left-string start-idx))) |
|---|
| 557 | |
|---|
| 558 | |
|---|
| 559 | (defun find-+--right-scope (right-string) |
|---|
| 560 | "Returns the string that is the right part of the binary scope." |
|---|
| 561 | (declare (String right-string)) |
|---|
| 562 | (let* ((first-pos (search-first-ignore-literals |
|---|
| 563 | (append (*supported-arithmetic-operators*) |
|---|
| 564 | *supported-compare-operators*) |
|---|
| 565 | right-string)) |
|---|
| 566 | (first-bracket |
|---|
| 567 | (let ((inner-value (search-first-unopened-paranthesis right-string))) |
|---|
| 568 | (when inner-value (1+ inner-value)))) |
|---|
| 569 | (paranthesis-pair-idx |
|---|
| 570 | (let* ((cleaned-str (trim-whitespace-left right-string)) |
|---|
| 571 | (bracket-scope (bracket-scope cleaned-str))) |
|---|
| 572 | (when bracket-scope |
|---|
| 573 | (+ (- (length right-string) (length cleaned-str)) |
|---|
| 574 | (length bracket-scope))))) |
|---|
| 575 | (end-idx (cond (paranthesis-pair-idx |
|---|
| 576 | paranthesis-pair-idx) |
|---|
| 577 | ((and first-pos first-bracket) |
|---|
| 578 | (min first-pos first-bracket)) |
|---|
| 579 | (first-pos first-pos) |
|---|
| 580 | (first-bracket first-bracket) |
|---|
| 581 | (t (if (= (length right-string) 0) |
|---|
| 582 | (1- (length right-string))))))) |
|---|
| 583 | (subseq right-string 0 end-idx))) |
|---|
| 584 | |
|---|
| 585 | |
|---|
| 586 | (defun find-+--operators (filter-string) |
|---|
| 587 | "Returns the idx of the first found + or - operator. |
|---|
| 588 | It must not be in a literal string or directly after a (." |
|---|
| 589 | (declare (String filter-string)) |
|---|
| 590 | (let ((first-pos |
|---|
| 591 | (search-first-ignore-literals *supported-secundary-arithmetic-operators* |
|---|
| 592 | filter-string))) |
|---|
| 593 | (when first-pos |
|---|
| 594 | (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos)))) |
|---|
| 595 | (if (and (not (string-ends-with left-part "(one")) |
|---|
| 596 | (not (string-ends-with left-part "("))) |
|---|
| 597 | first-pos |
|---|
| 598 | (let ((next-pos |
|---|
| 599 | (find-+--operators (subseq filter-string (1+ first-pos))))) |
|---|
| 600 | (when next-pos |
|---|
| 601 | (+ 1 first-pos next-pos)))))))) |
|---|
| 602 | |
|---|
| 603 | |
|---|
| 604 | (defgeneric set-or-and-operators (construct filter-string original-filter-string) |
|---|
| 605 | (:documentation "Transforms the || and && operators in the filter string to |
|---|
| 606 | the the lisp or and and functions.") |
|---|
| 607 | (:method ((construct SPARQL-Query) (filter-string String) |
|---|
| 608 | (original-filter-string String)) |
|---|
| 609 | (let ((op-pos (search-first-ignore-literals |
|---|
| 610 | *supported-join-operators* filter-string))) |
|---|
| 611 | (if (not op-pos) |
|---|
| 612 | filter-string |
|---|
| 613 | (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos))) |
|---|
| 614 | (left-str (subseq filter-string 0 op-pos)) |
|---|
| 615 | (right-str (subseq filter-string (+ (length op-str) op-pos))) |
|---|
| 616 | (left-scope (find-or-and-left-scope left-str)) |
|---|
| 617 | (right-scope (find-or-and-right-scope right-str)) |
|---|
| 618 | (modified-str |
|---|
| 619 | (concat (subseq left-str 0 (- (length left-str) |
|---|
| 620 | (length left-scope))) |
|---|
| 621 | "(" (if (string= op-str "||") "or" "and") " " |
|---|
| 622 | "(progn " left-scope ")" "(progn " right-scope ")) " |
|---|
| 623 | (subseq right-str (length right-scope))))) |
|---|
| 624 | (when (or (= (length (trim-whitespace left-scope)) 0) |
|---|
| 625 | (= (length (trim-whitespace right-scope)) 0)) |
|---|
| 626 | (error (make-condition |
|---|
| 627 | 'sparql-parser-error |
|---|
| 628 | :message (format nil "Invalid filter: \"~a\", expect an RDF term after and before: \"~a\"" original-filter-string op-str)))) |
|---|
| 629 | (set-or-and-operators construct modified-str original-filter-string)))))) |
|---|
| 630 | |
|---|
| 631 | |
|---|
| 632 | (defun find-binary-op-string (filter-string idx) |
|---|
| 633 | "Returns the operator as string that is placed on the position idx." |
|---|
| 634 | (let* ((2-ops |
|---|
| 635 | (remove-null (map 'list #'(lambda(op-string) |
|---|
| 636 | (when (= (length op-string) 2) |
|---|
| 637 | op-string)) |
|---|
| 638 | (*supported-binary-operators*)))) |
|---|
| 639 | (operator-str (subseq filter-string idx))) |
|---|
| 640 | (if (string-starts-with-one-of operator-str 2-ops) |
|---|
| 641 | (subseq operator-str 0 2) |
|---|
| 642 | (subseq operator-str 0 1)))) |
|---|
| 643 | |
|---|
| 644 | |
|---|
| 645 | (defun find-or-and-left-scope (left-string) |
|---|
| 646 | "Returns the string that is the left part of the binary scope." |
|---|
| 647 | (declare (String left-string)) |
|---|
| 648 | (let* ((first-bracket |
|---|
| 649 | (let ((inner-value (search-first-unclosed-paranthesis left-string))) |
|---|
| 650 | (when inner-value |
|---|
| 651 | (+ inner-value (1+ (length (name-after-paranthesis |
|---|
| 652 | (subseq left-string inner-value)))))))) |
|---|
| 653 | |
|---|
| 654 | (start-idx (if first-bracket |
|---|
| 655 | first-bracket |
|---|
| 656 | 0))) |
|---|
| 657 | (subseq left-string start-idx))) |
|---|
| 658 | |
|---|
| 659 | |
|---|
| 660 | (defun name-after-paranthesis (str) |
|---|
| 661 | "Returns the substring that is contained after the paranthesis. |
|---|
| 662 | str must start with a ( otherwise the returnvalue is nil." |
|---|
| 663 | (declare (String str)) |
|---|
| 664 | (let ((result "") |
|---|
| 665 | (non-whitespace-found nil)) |
|---|
| 666 | (when (string-starts-with str "(") |
|---|
| 667 | (let ((cleaned-str (subseq str 1))) |
|---|
| 668 | (dotimes (idx (length cleaned-str)) |
|---|
| 669 | (let ((current-char (subseq cleaned-str idx (1+ idx)))) |
|---|
| 670 | (cond ((string-starts-with-one-of current-char (list "(" ")")) |
|---|
| 671 | (setf idx (length cleaned-str))) |
|---|
| 672 | ((and non-whitespace-found |
|---|
| 673 | (white-space-p current-char)) |
|---|
| 674 | (setf idx (length cleaned-str))) |
|---|
| 675 | ((white-space-p current-char) |
|---|
| 676 | (push-string current-char result)) |
|---|
| 677 | (t |
|---|
| 678 | (push-string current-char result) |
|---|
| 679 | (setf non-whitespace-found t))))) |
|---|
| 680 | result)))) |
|---|
| 681 | |
|---|
| 682 | |
|---|
| 683 | (defun find-or-and-right-scope (right-string) |
|---|
| 684 | "Returns the string that is the right part of the binary scope." |
|---|
| 685 | (declare (String right-string)) |
|---|
| 686 | (let* ((first-pos (search-first-ignore-literals |
|---|
| 687 | *supported-join-operators* right-string)) |
|---|
| 688 | (first-bracket |
|---|
| 689 | (let ((inner-value (search-first-unopened-paranthesis right-string))) |
|---|
| 690 | (when inner-value (1+ inner-value)))) |
|---|
| 691 | (paranthesis-pair-idx |
|---|
| 692 | (let* ((cleaned-str (trim-whitespace-left right-string)) |
|---|
| 693 | (bracket-scope (bracket-scope cleaned-str))) |
|---|
| 694 | (when bracket-scope |
|---|
| 695 | (+ (- (length right-string) (length cleaned-str)) |
|---|
| 696 | (length bracket-scope))))) |
|---|
| 697 | (end-idx |
|---|
| 698 | (cond ((and first-pos first-bracket) |
|---|
| 699 | (if (< first-pos first-bracket) |
|---|
| 700 | (if paranthesis-pair-idx |
|---|
| 701 | (if (< first-pos paranthesis-pair-idx) |
|---|
| 702 | paranthesis-pair-idx |
|---|
| 703 | first-pos) |
|---|
| 704 | first-pos) |
|---|
| 705 | first-bracket)) |
|---|
| 706 | (first-bracket first-bracket) |
|---|
| 707 | (first-pos |
|---|
| 708 | (if paranthesis-pair-idx |
|---|
| 709 | (if (< first-pos paranthesis-pair-idx) |
|---|
| 710 | paranthesis-pair-idx |
|---|
| 711 | first-pos) |
|---|
| 712 | first-pos)) |
|---|
| 713 | (t |
|---|
| 714 | (if (= (length right-string) 0) |
|---|
| 715 | 0 |
|---|
| 716 | (length right-string)))))) |
|---|
| 717 | (subseq right-string 0 end-idx))) |
|---|
| 718 | |
|---|
| 719 | |
|---|
| 720 | (defgeneric set-unary-operators (construct filter-string) |
|---|
| 721 | (:documentation "Transforms the unary operators !, +, - to (not ), |
|---|
| 722 | (one+ ) and (one- ). The return value is a modified filter |
|---|
| 723 | string.") |
|---|
| 724 | (:method ((construct SPARQL-Query) (filter-string String)) |
|---|
| 725 | (let ((result-string "")) |
|---|
| 726 | (dotimes (idx (length filter-string)) |
|---|
| 727 | (let ((current-char (subseq filter-string idx (1+ idx)))) |
|---|
| 728 | (cond ((string= current-char "!") |
|---|
| 729 | (if (and (< idx (1- (length filter-string))) |
|---|
| 730 | (string= (subseq filter-string (1+ idx) (+ 2 idx)) "=")) |
|---|
| 731 | (push-string current-char result-string) |
|---|
| 732 | (let ((result (unary-operator-scope filter-string idx))) |
|---|
| 733 | (push-string "(not " result-string) |
|---|
| 734 | (push-string (set-unary-operators construct (getf result :scope)) |
|---|
| 735 | result-string) |
|---|
| 736 | (push-string ")" result-string) |
|---|
| 737 | (setf idx (- (1- (length filter-string)) |
|---|
| 738 | (length (getf result :next-query))))))) |
|---|
| 739 | ((or (string= current-char "-") |
|---|
| 740 | (string= current-char "+")) |
|---|
| 741 | (let ((string-before |
|---|
| 742 | (trim-whitespace-right (subseq filter-string 0 idx)))) |
|---|
| 743 | (if (or (string= string-before "") |
|---|
| 744 | (string-ends-with string-before "(progn") |
|---|
| 745 | (string-ends-with-one-of |
|---|
| 746 | string-before (append (*supported-operators*) (list "(")))) |
|---|
| 747 | (let ((result (unary-operator-scope filter-string idx))) |
|---|
| 748 | (push-string (concat "(one" current-char " ") |
|---|
| 749 | result-string) |
|---|
| 750 | (push-string (set-unary-operators construct |
|---|
| 751 | (getf result :scope)) |
|---|
| 752 | result-string) |
|---|
| 753 | (push-string ")" result-string) |
|---|
| 754 | (setf idx (- (1- (length filter-string)) |
|---|
| 755 | (length (getf result :next-query))))) |
|---|
| 756 | (push-string current-char result-string)))) |
|---|
| 757 | ((or (string= current-char "'") |
|---|
| 758 | (string= current-char "\"")) |
|---|
| 759 | (let ((literal |
|---|
| 760 | (get-literal (subseq filter-string idx)))) |
|---|
| 761 | (if literal |
|---|
| 762 | (progn |
|---|
| 763 | (setf idx (- (1- (length filter-string)) |
|---|
| 764 | (length (getf literal :next-string)))) |
|---|
| 765 | (push-string (getf literal :literal) result-string)) |
|---|
| 766 | (push-string current-char result-string)))) |
|---|
| 767 | (t |
|---|
| 768 | (push-string current-char result-string))))) |
|---|
| 769 | result-string))) |
|---|
| 770 | |
|---|
| 771 | |
|---|
| 772 | (defun unary-operator-scope (filter-string idx) |
|---|
| 773 | "Returns a list of the form (:next-query <string> :scope <string>). |
|---|
| 774 | scope contains the statement that is in the scope of one of the following |
|---|
| 775 | operators !, +, -." |
|---|
| 776 | (declare (String filter-string) |
|---|
| 777 | (Integer idx)) |
|---|
| 778 | (let* ((string-after (subseq filter-string (1+ idx))) |
|---|
| 779 | (cleaned-str (trim-whitespace-left string-after))) |
|---|
| 780 | (cond ((string-starts-with cleaned-str "(") |
|---|
| 781 | (let ((result (bracket-scope cleaned-str))) |
|---|
| 782 | (list :next-query (string-after cleaned-str result) |
|---|
| 783 | :scope result))) |
|---|
| 784 | ((or (string-starts-with cleaned-str "?") |
|---|
| 785 | (string-starts-with cleaned-str "$")) |
|---|
| 786 | (let ((result (get-filter-variable cleaned-str))) |
|---|
| 787 | (list :next-query (string-after cleaned-str result) |
|---|
| 788 | :scope result))) |
|---|
| 789 | ((string-starts-with cleaned-str "\"") |
|---|
| 790 | (let ((result (get-literal cleaned-str :quotation "\""))) |
|---|
| 791 | (list :next-query (getf result :next-string) |
|---|
| 792 | :scope (getf result :literal)))) |
|---|
| 793 | ((string-starts-with-digit cleaned-str) |
|---|
| 794 | (let ((result (separate-leading-digits cleaned-str))) |
|---|
| 795 | (list :next-query (string-after cleaned-str result) |
|---|
| 796 | :scope result))) |
|---|
| 797 | ((string-starts-with cleaned-str "true") |
|---|
| 798 | (list :next-query (string-after cleaned-str "true") |
|---|
| 799 | :scope "true")) |
|---|
| 800 | ((string-starts-with cleaned-str "false") |
|---|
| 801 | (list :next-query (string-after cleaned-str "false") |
|---|
| 802 | :scope "false")) |
|---|
| 803 | ((let ((pos (search-first *supported-functions* cleaned-str))) |
|---|
| 804 | (when pos |
|---|
| 805 | (= pos 0))) |
|---|
| 806 | (let ((result (function-scope cleaned-str))) |
|---|
| 807 | (list :next-query (string-after cleaned-str result) |
|---|
| 808 | :scope result))) |
|---|
| 809 | (t |
|---|
| 810 | (error |
|---|
| 811 | (make-condition |
|---|
| 812 | 'sparql-parser-error |
|---|
| 813 | :message |
|---|
| 814 | (format |
|---|
| 815 | nil "Invalid filter: \"~a\". An unary operator must be followed by ~a" |
|---|
| 816 | filter-string |
|---|
| 817 | "a number, boolean, string, function or a variable"))))))) |
|---|
| 818 | |
|---|
| 819 | |
|---|
| 820 | (defun function-scope (str) |
|---|
| 821 | "If str starts with a supported function there is given the entire substr |
|---|
| 822 | that is the scope of the function, i.e. the function name and all its |
|---|
| 823 | variable including the closing )." |
|---|
| 824 | (declare (String str)) |
|---|
| 825 | (let* ((cleaned-str (trim-whitespace-left str)) |
|---|
| 826 | (after-fun |
|---|
| 827 | (remove-null (map 'list #'(lambda(fun) |
|---|
| 828 | (when (string-starts-with cleaned-str fun) |
|---|
| 829 | (string-after str fun))) |
|---|
| 830 | *supported-functions*))) |
|---|
| 831 | (fun-suffix (when after-fun |
|---|
| 832 | (trim-whitespace-left (first after-fun))))) |
|---|
| 833 | (when fun-suffix |
|---|
| 834 | (let* ((args (bracket-scope fun-suffix)) |
|---|
| 835 | (fun-name (string-until cleaned-str args))) |
|---|
| 836 | (concat fun-name args))))) |
|---|
| 837 | |
|---|
| 838 | |
|---|
| 839 | (defun get-filter-variable (str) |
|---|
| 840 | "Returns the substring of str if str starts with ? or $ until the variable ends, |
|---|
| 841 | otherwise the return value is nil." |
|---|
| 842 | (declare (String str)) |
|---|
| 843 | (when (or (string-starts-with str "?") |
|---|
| 844 | (string-starts-with str "$")) |
|---|
| 845 | (let ((found-end (search-first (append (white-space) (*supported-operators*) |
|---|
| 846 | *supported-brackets* (list "?" "$")) |
|---|
| 847 | (subseq str 1)))) |
|---|
| 848 | (if found-end |
|---|
| 849 | (subseq str 0 (1+ found-end)) |
|---|
| 850 | str)))) |
|---|
| 851 | |
|---|
| 852 | |
|---|
| 853 | (defun reverse-bracket-scope (str &key (open-bracket "(") (close-bracket ")")) |
|---|
| 854 | "If str ends with close-bracket there will be returned the substring until |
|---|
| 855 | the matching open-bracket is found. Otherwise the return value is nil." |
|---|
| 856 | (declare (String str open-bracket close-bracket)) |
|---|
| 857 | (when (string-ends-with str close-bracket) |
|---|
| 858 | (let ((local-str (subseq str 0 (1- (length str)))) |
|---|
| 859 | (result ")") |
|---|
| 860 | (close-brackets 1)) |
|---|
| 861 | (do ((idx (1- (length local-str)))) ((< idx 0)) |
|---|
| 862 | (let ((current-char (subseq local-str idx (1+ idx)))) |
|---|
| 863 | (push-string current-char result) |
|---|
| 864 | (cond ((string= current-char open-bracket) |
|---|
| 865 | (when (not (in-literal-string-p local-str idx)) |
|---|
| 866 | (decf close-brackets)) |
|---|
| 867 | (when (= close-brackets 0) |
|---|
| 868 | (setf idx 0))) |
|---|
| 869 | ((string= current-char close-bracket) |
|---|
| 870 | (when (not (in-literal-string-p local-str idx)) |
|---|
| 871 | (incf close-brackets))))) |
|---|
| 872 | (decf idx)) |
|---|
| 873 | (reverse result)))) |
|---|
| 874 | |
|---|
| 875 | |
|---|
| 876 | (defun bracket-scope (str &key (open-bracket "(") (close-bracket ")")) |
|---|
| 877 | "If str starts with open-bracket there will be returned the substring until |
|---|
| 878 | the matching close-bracket is found. Otherwise the return value is nil." |
|---|
| 879 | (declare (String str open-bracket close-bracket)) |
|---|
| 880 | (when (string-starts-with str open-bracket) |
|---|
| 881 | (let ((open-brackets 0) |
|---|
| 882 | (result "")) |
|---|
| 883 | (dotimes (idx (length str)) |
|---|
| 884 | (let ((current-char (subseq str idx (1+ idx)))) |
|---|
| 885 | (cond ((or (string= "'" current-char) |
|---|
| 886 | (string= "\"" current-char)) |
|---|
| 887 | (let ((literal (get-literal (subseq str idx)))) |
|---|
| 888 | (if literal |
|---|
| 889 | (progn |
|---|
| 890 | (setf idx (- (1- (length str)) |
|---|
| 891 | (length (getf literal :next-string)))) |
|---|
| 892 | (push-string (getf literal :literal) result)) |
|---|
| 893 | (progn |
|---|
| 894 | (setf result nil) |
|---|
| 895 | (setf idx (length str)))))) |
|---|
| 896 | ((string= current-char close-bracket) |
|---|
| 897 | (decf open-brackets) |
|---|
| 898 | (push-string current-char result) |
|---|
| 899 | (when (= open-brackets 0) |
|---|
| 900 | (setf idx (length str)))) |
|---|
| 901 | ((string= current-char open-bracket) |
|---|
| 902 | (incf open-brackets) |
|---|
| 903 | (push-string current-char result)) |
|---|
| 904 | (t |
|---|
| 905 | (push-string current-char result))))) |
|---|
| 906 | result))) |
|---|
| 907 | |
|---|
| 908 | |
|---|
| 909 | (defgeneric set-boundings (construct query-string) |
|---|
| 910 | (:documentation "Returns a list of the form (:next-query <string> |
|---|
| 911 | :filter-string <string>). next-query is a string containing |
|---|
| 912 | the query after the filter and filter is a string |
|---|
| 913 | containing the actual filter. Additionally all free |
|---|
| 914 | '(' are transformed into '(progn' and all ', ''', \"\"\" |
|---|
| 915 | are transformed into \".") |
|---|
| 916 | (:method ((construct SPARQL-Query) (query-string String)) |
|---|
| 917 | (let ((filter-string "") |
|---|
| 918 | (open-brackets 0) |
|---|
| 919 | (result nil)) |
|---|
| 920 | (dotimes (idx (length query-string)) |
|---|
| 921 | (let ((current-char (subseq query-string idx (1+ idx)))) |
|---|
| 922 | (cond ((string= "(" current-char) |
|---|
| 923 | (setf open-brackets (1+ open-brackets)) |
|---|
| 924 | (if (progn-p query-string idx) |
|---|
| 925 | (push-string "(progn " filter-string) |
|---|
| 926 | (push-string current-char filter-string))) |
|---|
| 927 | ((string= ")" current-char) |
|---|
| 928 | (setf open-brackets (1- open-brackets)) |
|---|
| 929 | (when (< open-brackets 0) |
|---|
| 930 | (error |
|---|
| 931 | (make-sparql-parser-condition |
|---|
| 932 | (subseq query-string idx) |
|---|
| 933 | (original-query construct) |
|---|
| 934 | "an opening bracket \"(\" is missing for the current closing one"))) |
|---|
| 935 | (push-string current-char filter-string)) |
|---|
| 936 | ((or (string= "'" current-char) |
|---|
| 937 | (string= "\"" current-char)) |
|---|
| 938 | (let ((result |
|---|
| 939 | (get-literal (subseq query-string idx) :quotation "\""))) |
|---|
| 940 | (unless result |
|---|
| 941 | (error (make-sparql-parser-condition |
|---|
| 942 | (subseq query-string idx) |
|---|
| 943 | (original-query construct) |
|---|
| 944 | "a closing character for the given literal"))) |
|---|
| 945 | (setf idx (- (1- (length query-string)) |
|---|
| 946 | (length (getf result :next-string)))) |
|---|
| 947 | (push-string (getf result :literal) filter-string))) |
|---|
| 948 | ((and (string= current-char (string #\newline)) |
|---|
| 949 | (= 0 open-brackets)) |
|---|
| 950 | (setf result |
|---|
| 951 | (list :next-query (subseq query-string idx) |
|---|
| 952 | :filter-string filter-string)) |
|---|
| 953 | (setf idx (1- (length query-string)))) |
|---|
| 954 | ((string= current-char "}") |
|---|
| 955 | (when (/= open-brackets 0) |
|---|
| 956 | (error (make-sparql-parser-condition |
|---|
| 957 | (subseq query-string idx) |
|---|
| 958 | (original-query construct) |
|---|
| 959 | (format nil |
|---|
| 960 | "a valid filter, but the filter is not complete, ~a" |
|---|
| 961 | (if (> open-brackets 0) |
|---|
| 962 | (format nil "~a ')' is missing" |
|---|
| 963 | open-brackets) |
|---|
| 964 | (format nil "~a '(' is missing" |
|---|
| 965 | open-brackets)))))) |
|---|
| 966 | (setf result |
|---|
| 967 | (list :next-query (subseq query-string idx) |
|---|
| 968 | :filter-string filter-string))) |
|---|
| 969 | (t |
|---|
| 970 | (push-string current-char filter-string))))) |
|---|
| 971 | result))) |
|---|
| 972 | |
|---|
| 973 | |
|---|
| 974 | (defun progn-p(query-string idx) |
|---|
| 975 | "Returns t if the ( at position idx in the filter string |
|---|
| 976 | represents a (progn) block." |
|---|
| 977 | (declare (String query-string) |
|---|
| 978 | (Integer idx)) |
|---|
| 979 | (let* ((delimiters (append (list " " "," (string #\Space) (string #\Tab) |
|---|
| 980 | (string #\Newline) (string #\cr) "(" ")") |
|---|
| 981 | (*supported-operators*))) |
|---|
| 982 | (string-before (trim-whitespace-right (subseq query-string 0 idx))) |
|---|
| 983 | (fragment-before-idx |
|---|
| 984 | (search-first delimiters string-before :from-end t)) |
|---|
| 985 | (fragment-before |
|---|
| 986 | (if (and (not fragment-before-idx) |
|---|
| 987 | (and (> (length string-before) 0) |
|---|
| 988 | (not (string-ends-with-one-of |
|---|
| 989 | (trim-whitespace-right string-before) |
|---|
| 990 | *supported-functions*)))) |
|---|
| 991 | (error (make-condition |
|---|
| 992 | 'SPARQL-PARSER-ERROR |
|---|
| 993 | :message (format nil "Invalid filter: \"~a\"~%" |
|---|
| 994 | query-string))) |
|---|
| 995 | (if fragment-before-idx |
|---|
| 996 | (subseq string-before fragment-before-idx) |
|---|
| 997 | nil)))) |
|---|
| 998 | (when fragment-before |
|---|
| 999 | (mapcan #'(lambda(operator) |
|---|
| 1000 | (when (and (string-starts-with fragment-before operator) |
|---|
| 1001 | (> (length fragment-before) (length operator))) |
|---|
| 1002 | (setf fragment-before |
|---|
| 1003 | (string-after fragment-before operator)))) |
|---|
| 1004 | (append (*supported-operators*) *supported-brackets*))) |
|---|
| 1005 | (if fragment-before |
|---|
| 1006 | (progn |
|---|
| 1007 | (when (or (string-starts-with fragment-before "?") |
|---|
| 1008 | (string-starts-with fragment-before "$")) |
|---|
| 1009 | (error |
|---|
| 1010 | (make-condition |
|---|
| 1011 | 'SPARQL-PARSER-ERROR |
|---|
| 1012 | :message (format nil "Invalid filter: found \"~a\" but expected ~a" |
|---|
| 1013 | fragment-before *supported-functions*)))) |
|---|
| 1014 | (when (not (string-starts-with-one-of |
|---|
| 1015 | fragment-before (append *supported-functions* delimiters))) |
|---|
| 1016 | (error |
|---|
| 1017 | (make-condition |
|---|
| 1018 | 'SPARQL-PARSER-ERROR |
|---|
| 1019 | :message |
|---|
| 1020 | (format nil "Invalid character: \"~a\", expected characters: ~a" |
|---|
| 1021 | fragment-before (append *supported-functions* delimiters))))) |
|---|
| 1022 | (if (string-ends-with-one-of fragment-before *supported-functions*) |
|---|
| 1023 | nil |
|---|
| 1024 | t)) |
|---|
| 1025 | (if (find string-before *supported-functions* :test #'string=) |
|---|
| 1026 | nil |
|---|
| 1027 | t)))) |
|---|
| 1028 | |
|---|
| 1029 | |
|---|
| 1030 | (defun get-variables-from-filter-string(filter-string) |
|---|
| 1031 | "Returns a list of string with all variables that are used in this filter." |
|---|
| 1032 | (let ((variables nil)) |
|---|
| 1033 | (dotimes (idx (length filter-string)) |
|---|
| 1034 | (let ((current-string (subseq filter-string idx))) |
|---|
| 1035 | (cond ((and (or (string-starts-with current-string "?") |
|---|
| 1036 | (string-starts-with current-string "$")) |
|---|
| 1037 | (not (in-literal-string-p filter-string idx))) |
|---|
| 1038 | (let ((end-pos |
|---|
| 1039 | (let ((inner-value |
|---|
| 1040 | (search-first |
|---|
| 1041 | (append (list " " "?" "$" "." ",") |
|---|
| 1042 | (*supported-operators*) |
|---|
| 1043 | *supported-brackets* |
|---|
| 1044 | (map 'list #'string (white-space))) |
|---|
| 1045 | (subseq current-string 1)))) |
|---|
| 1046 | (if inner-value |
|---|
| 1047 | (1+ inner-value) |
|---|
| 1048 | (length current-string))))) |
|---|
| 1049 | (push (subseq current-string 1 end-pos) variables) |
|---|
| 1050 | (incf idx end-pos))) |
|---|
| 1051 | ;BOUND needs a separate hanlding since all variables |
|---|
| 1052 | ; were written into strings so they have to be |
|---|
| 1053 | ; searched different |
|---|
| 1054 | ((and (string-starts-with current-string "BOUND ") |
|---|
| 1055 | (not (in-literal-string-p filter-string idx))) |
|---|
| 1056 | (let* ((next-str (subseq current-string (length "BOUND "))) |
|---|
| 1057 | (literal (when (string-starts-with next-str "\"") |
|---|
| 1058 | (let ((val (get-literal next-str))) |
|---|
| 1059 | (when val |
|---|
| 1060 | (getf val :literal)))))) |
|---|
| 1061 | (when (and literal (> (length literal) 3)) ;"?.." | "$.." |
|---|
| 1062 | (push (subseq (string-trim (list #\") literal) 1) variables)) |
|---|
| 1063 | (incf idx (+ (length "BOUND ") (length literal)))))))) |
|---|
| 1064 | (remove-duplicates variables :test #'string=))) |
|---|
