From lgiessmann at common-lisp.net  Thu Dec  2 19:53:40 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 02 Dec 2010 14:53:40 -0500
Subject: [isidorus-cvs] r357 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1POFDo-00040m-UM@common-lisp.net>

Author: lgiessmann
Date: Thu Dec  2 14:53:40 2010
New Revision: 357

Log:
TM-SPARQL: added more unit-tests for the sparql-interface => fixed some bug when processing query-triples in the SELECT-WHERE statement

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Thu Dec  2 14:53:40 2010
@@ -431,7 +431,7 @@
     (declare (Integer revision))
     (when (and (not (iri-p (object construct)))
 	       (or (not (literal-datatype (object construct)))
-		   (string= (literal-datatype construct) *xml-string*)))
+		   (string= (literal-datatype (object construct)) *xml-string*)))
       (let* ((names-by-type
 	      (remove-null
 	       (map 'list #'(lambda(typed-construct)
@@ -521,7 +521,7 @@
 			subj pred nil :revision revision)))
 	      ((literal-p (object construct))
 	       (filter-characteristics
-		subj pred (value (subject construct))
+		subj pred (value (object construct))
 		(literal-datatype (object construct)) :revision revision))
 	      ((iri-p (object construct))
 	       (filter-associations subj pred (value (object construct))
@@ -621,7 +621,9 @@
 	     (type (or Null String) literal-value literal-datatype)
 	     (type (or Null TopicC) type-top))
     (let* ((occs-by-type
-	    (occurrences-by-type construct type-top :revision revision))
+	    (if type-top
+		(occurrences-by-type construct type-top :revision revision)
+		(occurrences construct :revision revision)))
 	   (all-occs
 	    (remove-null
 	     (map 'list
@@ -650,8 +652,10 @@
     (declare (Integer revision)
 	     (type (or Null String) literal-value)
 	     (type (or Null TopicC) type-top))
-    (let* ((by-type 
-	    (names-by-type construct type-top :revision revision))
+    (let* ((by-type
+	    (if type-top
+		(names-by-type construct type-top :revision revision)
+		(names construct :revision revision)))
 	   (by-literal (if literal-value
 			   (names-by-value
 			    construct #'(lambda(name)
@@ -693,36 +697,48 @@
 
 (defgeneric filter-associations(construct type-top player-top
 					  &key revision)
-  (:documentation "Returns a list of the form (:type <uri> :value <uri>).
-                   type-identifier is the type of the otherrole and
-                   player-identifier if the otherplayer.")
+  (:documentation "Returns a list of the form (:predicate <uri>
+                   :object <uri> :subject <uri>).
+                   predicate is the type of the otherrole and
+                   object is the uri of the otherplayer.")
   (:method ((construct TopicC) type-top player-top
 	    &key (revision *TM-REVISION*))
     (declare (Integer revision)
 	     (type (or Null TopicC) type-top player-top))
     (let ((assocs
 	   (associations-of construct nil nil type-top player-top
-			    :revision revision)))
+			    :revision revision))
+	  (subj-uri (any-id construct :revision revision)))
       (remove-null ;only assocs with two roles can match!
        (map 'list
 	    #'(lambda(assoc)
 		(when (= (length (roles assoc :revision revision)) 2)
 		  (let* ((other-role
 			  (find-if #'(lambda(role)
-				       (not (eql construct
-						 (player role :revision revision))))
+				       (and
+					(not (eql construct
+						  (player role :revision revision)))
+					(or (not type-top)
+					    (eql type-top
+						 (instance-of
+						  role :revision revision)))))
 				   (roles assoc :revision revision)))
 			 (pred-uri
-			  (when-do type-top (instance-of other-role
-							 :revision revision)
-				   (any-id type-top :revision revision)))
+			  (when other-role
+			    (when-do
+			     type-top (instance-of other-role
+						   :revision revision)
+			     (any-id type-top :revision revision))))
+			 
 			 (obj-uri
-			  (when-do player-top (player other-role
-						      :revision revision)
-				   (any-id player-top :revision revision))))
+			  (when other-role
+			    (when-do player-top (player other-role
+							:revision revision)
+				     (any-id player-top :revision revision)))))
 		    (when (and pred-uri obj-uri)
-		      (list :type pred-uri
-			    :value obj-uri)))))
+		      (list :subject subj-uri
+			    :predicate pred-uri
+			    :object obj-uri)))))
 	    assocs)))))
 
 

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Thu Dec  2 14:53:40 2010
@@ -168,7 +168,9 @@
 	   (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)))
+	   (let ((result
+		  (parse-variable-name trimmed-str query-object
+				       :additional-delimiters (list "}"))))
 	     (list :next-query (cut-comment (getf result :next-query))
 		   :value (make-instance 'SPARQL-Triple-Elem
 					 :elem-type 'VARIABLE
@@ -269,11 +271,11 @@
 		   :message (format nil "Could not cast from ~a to ~a"
 				    literal-value literal-type))))
 	   value))
-	(t
-	 (error (make-condition
-		 'sparql-error 
-		 :message (format nil "The type \"~a\" is not supported."
-				  literal-type))))))
+	(t ; return the value as a string
+	 (if (stringp literal-value)
+	     literal-value
+	     (write-to-string literal-value)))))
+	 
 
 (defun separate-literal-lang-or-type (query-string query-object)
   "A helper function that returns (:next-query string :lang string
@@ -489,15 +491,18 @@
 		(parse-variables construct (getf result :next-query))))))))
 
 
-(defun parse-variable-name (query-string query-object)
+(defun parse-variable-name (query-string query-object &key additional-delimiters)
   "A helper function that parses the first non-whitespace character
    in the query. since it must be a variable, it must be prefixed
    by a ? or $. The return value is of the form
    (:next-query string :value string)."
   (declare (String query-string)
-	   (SPARQL-Query query-object))
+	   (SPARQL-Query query-object)
+	   (List additional-delimiters))
   (let ((trimmed-str (cut-comment query-string))
-	(delimiters (list " " "?" "$" "." (string #\newline) (string #\tab))))
+	(delimiters (append
+		     (list " " "?" "$" "." (string #\newline) (string #\tab))
+		     additional-delimiters)))
     (unless (or (string-starts-with trimmed-str "?")
 		(string-starts-with trimmed-str "$"))
       (error (make-sparql-parser-condition

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Thu Dec  2 14:53:40 2010
@@ -24,7 +24,10 @@
 	   :test-parse-group-1
 	   :test-parse-group-2
 	   :test-set-result-1
-	   :test-set-result-2))
+	   :test-set-result-2
+	   :test-set-result-3
+	   :test-set-result-4
+	   :test-set-result-5))
 
 
 (in-package :sparql-test)
@@ -183,35 +186,35 @@
 		   "literal-value"))
       (is (string= (tm-sparql::literal-lang (getf result :value))
 		   "de"))
-      (is (string= (tm-sparql::literal-type (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf result :value))
 		   *xml-string*))
       (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
     (let ((result (tm-sparql::parse-literal-elem query-2 dummy-object)))
       (is (string= (getf result :next-query) "."))
       (is (eql (tm-sparql::value (getf result :value)) t))
       (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-type (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf result :value))
 		   *xml-boolean*))
       (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
     (let ((result (tm-sparql::parse-literal-elem query-3 dummy-object)))
       (is (string= (getf result :next-query) "}"))
       (is (eql (tm-sparql::value (getf result :value)) nil))
       (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-type (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf result :value))
 		   *xml-boolean*))
       (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
     (let ((result (tm-sparql::parse-literal-elem query-4 dummy-object)))
       (is (string= (getf result :next-query) (string #\tab)))
       (is (= (tm-sparql::value (getf result :value)) 1234.43e10))
       (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-type (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf result :value))
 		   *xml-double*))
       (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
     (let ((result (tm-sparql::parse-literal-elem query-5 dummy-object)))
       (is (string= (getf result :next-query) ";"))
       (is (eql (tm-sparql::value (getf result :value)) t))
       (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-type (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf result :value))
 		   *xml-boolean*))
       (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
     (let ((result (tm-sparql::parse-literal-elem query-6 dummy-object)))
@@ -219,7 +222,7 @@
 		   (concatenate 'string "." (string #\newline))))
       (is (eql (tm-sparql::value (getf result :value)) 123.4))
       (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-type (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf result :value))
 		   *xml-double*))
       (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
     (let ((result (tm-sparql::parse-literal-elem query-7 dummy-object)))
@@ -229,7 +232,7 @@
 
 literal with some \\\"quoted\\\" words!"))
       (is (string= (tm-sparql::literal-lang (getf result :value)) "en"))
-      (is (string= (tm-sparql::literal-type (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf result :value))
 		   *xml-string*))
       (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
     (signals sparql-parser-error
@@ -322,7 +325,7 @@
 		   "http://prefix.value/predicate"))
       (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit))
       (is (= (tm-sparql::value (tm-sparql::object elem)) 1234.5e12))
-      (is (string= (tm-sparql::literal-type (tm-sparql::object elem))
+      (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem))
 		   *xml-double*))
       (is-false (tm-sparql::literal-lang (tm-sparql::object elem))))
     (is (string= (tm-sparql::parse-triple dummy-object query-3) ""))
@@ -336,7 +339,7 @@
 		   "predicate"))
       (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit))
       (is (string= (tm-sparql::value (tm-sparql::object elem)) "literal"))
-      (is (string= (tm-sparql::literal-type (tm-sparql::object elem))
+      (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem))
 		   *xml-string*))
       (is (string= (tm-sparql::literal-lang (tm-sparql::object elem)) "en")))))
 
@@ -368,7 +371,7 @@
 		   "http://base.value/predicate"))
       (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit))
       (is (eql (tm-sparql::value (tm-sparql::object elem)) t))
-      (is (string= (tm-sparql::literal-type (tm-sparql::object elem))
+      (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem))
 		   *xml-boolean*))
       (is-false (tm-sparql::literal-lang (tm-sparql::object elem))))
     (let ((elem (first (tm-sparql::select-group dummy-object))))
@@ -380,7 +383,7 @@
 		   "http://prefix.value/predicate-2"))
       (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit))
       (is (= (tm-sparql::value (tm-sparql::object elem)) 12))
-      (is (string= (tm-sparql::literal-type (tm-sparql::object elem))
+      (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem))
 		   *xml-integer*))
       (is-false (tm-sparql::literal-lang (tm-sparql::object elem))))
     (is (string= "http://base.value/" (tm-sparql::base-value dummy-object)))
@@ -396,7 +399,7 @@
 		   "http://base.value/predicate"))
       (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit))
       (is (eql (tm-sparql::value (tm-sparql::object elem)) nil))
-      (is (string= (tm-sparql::literal-type (tm-sparql::object elem))
+      (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem))
 		   *xml-boolean*))
       (is-false (tm-sparql::literal-lang (tm-sparql::object elem))))
     (let ((elem (first (tm-sparql::select-group dummy-object))))
@@ -408,7 +411,7 @@
 		   "http://new.base/predicate-2"))
       (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit))
       (is (string= (tm-sparql::value (tm-sparql::object elem)) "abc"))
-      (is (string= (tm-sparql::literal-type (tm-sparql::object elem))
+      (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem))
 		   *xml-string*))
       (is-false (tm-sparql::literal-lang (tm-sparql::object elem))))))
 
@@ -514,6 +517,8 @@
 	     (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))
 	     (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3)))
 	(is-true q-obj-1)
+	(is-true q-obj-2)
+	(is-true q-obj-3)
 	(is (= (length (tm-sparql::select-group q-obj-1)) 1))
 	(is (= (length (tm-sparql::subject-result
 			(first (tm-sparql::select-group q-obj-1)))) 4))
@@ -659,7 +664,279 @@
 	(is (string= (first (tm-sparql::object-result
 			     (first (tm-sparql::select-group q-obj-3))))
 		     "http://some.where/psis/poem/zauberlehrling"))))))
-      
+
+
+(test test-set-result-3
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let* ((query-1 "PREFIX pref:<http://some.where/base-psis/>
+                       SELECT $subject WHERE {
+                         ?subject pref:author-info \"http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe\"^^http://www.w3.org/2001/XMLSchema#anyURI }")
+	     (query-2 "BASE <http://some.where/base-psis/>
+                       SELECT $subject WHERE {
+                         ?subject <last-name> 'von Goethe'^^anyType }")
+	     (query-3 "BASE <http://some.where/base-psis/>
+                       SELECT ?subject WHERE{
+                         ?subject <http://some.where/base-psis/last-name>
+                           'Johann Wolfgang' }")
+	     (query-4 "PREFIX pref-1:<http://some.where/base-psis/>
+                       PREFIX pref-2:<http://some.where/psis/>
+                       SELECT ?subject WHERE {
+                         ?subject pref-1:written pref-2:poem/resignation }")
+	     (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))
+	     (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))
+	     (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))
+	     (q-obj-4 (make-instance 'TM-SPARQL:SPARQL-Query :query query-4)))
+	(is-true q-obj-1)
+	(is-true q-obj-2)
+	(is-true q-obj-3)
+	(is-true q-obj-4)
+	(is (= (length (tm-sparql::select-group q-obj-1)) 1))
+	(is (= (length (tm-sparql::select-group q-obj-2)) 1))
+	(is (= (length (tm-sparql::select-group q-obj-3)) 1))
+	(is (= (length (tm-sparql::select-group q-obj-4)) 1))
+	(is (= (length (tm-sparql::predicate-result
+			(first (tm-sparql::select-group q-obj-1)))) 1))
+	(is (= (length (tm-sparql::predicate-result
+			(first (tm-sparql::select-group q-obj-2)))) 0))
+	(is (= (length (tm-sparql::predicate-result
+			(first (tm-sparql::select-group q-obj-3)))) 0))
+	(is (or (string= (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-1))))
+			 "http://some.where/psis/author/goethe")
+		(string= (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-1))))
+			 "http://some.where/psis/persons/goethe")))
+	(is (string= (first (tm-sparql::predicate-result
+			     (first (tm-sparql::select-group q-obj-1))))
+		     "http://some.where/base-psis/author-info"))
+	(is (string= (first (tm-sparql::object-result
+			     (first (tm-sparql::select-group q-obj-1))))
+		     "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe"))
+	(is (string= (first (tm-sparql::subject-result
+			     (first (tm-sparql::select-group q-obj-4))))
+		     "http://some.where/psis/author/schiller"))
+	(is (string= (first (tm-sparql::predicate-result
+			     (first (tm-sparql::select-group q-obj-4))))
+		     "http://some.where/base-psis/written"))
+	(is (string= (first (tm-sparql::object-result
+			     (first (tm-sparql::select-group q-obj-4))))
+		     "http://some.where/psis/poem/resignation"))))))
+
+
+(test test-set-result-4
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let* ((query-1 "BASE <http://some.where/>
+                       SELECT ?predicate ?object WHERE {
+                         <psis/author/goethe> ?predicate ?object}")
+	     (query-2 "BASE <http://some.where/>
+                       SELECT ?predicate ?object WHERE {
+                         <psis/poem/zauberlehrling> ?predicate ?object}")
+	     (query-3 "BASE <http://some.where/>
+                       SELECT ?predicate WHERE {
+                         <psis/persons/goethe> ?predicate <psis/poem/zauberlehrling>}")
+	     (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))
+	     (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))
+	     (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3)))
+	(is-true q-obj-1)
+	(is-true q-obj-2)
+	(is-true q-obj-3)
+	(is (= (length (tm-sparql::select-group q-obj-1)) 1))
+	(is (= (length (tm-sparql::select-group q-obj-2)) 1))
+	(is (= (length (tm-sparql::select-group q-obj-3)) 1))
+	(is (= (length (tm-sparql::subject-result
+			(first (tm-sparql::select-group q-obj-1)))) 7))
+	(is (= (length (tm-sparql::subject-result
+			(first (tm-sparql::select-group q-obj-2)))) 4))
+	(is (= (length (tm-sparql::subject-result
+			(first (tm-sparql::select-group q-obj-3)))) 1))
+	(is-true (or (null (set-exclusive-or
+			    (list "http://some.where/psis/author/goethe")
+			    (tm-sparql::subject-result
+			     (first (tm-sparql::select-group q-obj-1)))
+			    :test #'string=))
+		     (null (set-exclusive-or
+			    (list "http://some.where/psis/persons/goethe")
+			    (tm-sparql::subject-result
+			     (first (tm-sparql::select-group q-obj-1)))
+			    :test #'string=))))
+	(let ((predicates (tm-sparql::predicate-result
+			   (first (tm-sparql::select-group q-obj-1)))))
+	  (is (= (count "http://some.where/base-psis/written" predicates
+			:test #'string=) 2))
+	  (is (= (count "http://some.where/base-psis/place" predicates
+			:test #'string=) 1))
+	  (is (= (count "http://some.where/base-psis/first-name" predicates
+			:test #'string=) 1))
+	  (is (= (count "http://some.where/base-psis/last-name" predicates
+			:test #'string=) 1))
+	  (is (= (count "http://some.where/base-psis/author-info" predicates
+			:test #'string=) 1))
+	  (is (= (count "http://psi.topicmaps.org/iso13250/model/type" predicates
+			:test #'string=) 1)))
+	(let ((objects (tm-sparql::object-result
+			(first (tm-sparql::select-group q-obj-1)))))
+	  (is (= (count "http://some.where/psis/poem/erlkoenig" objects
+			:test #'string=) 1))
+	  (is (or (= (count "http://some.where/psis/poem/der_zauberlehrling"
+			    objects :test #'string=) 1)
+		  (= (count "http://some.where/psis/poem/zauberlehrling" objects
+			    :test #'string=) 1)))
+	  (is (or (= (count "http://some.where/base-psis/author" objects
+			    :test #'string=) 1)
+		  (= (count "http://some.where/base-psis/author-psi" objects
+			    :test #'string=) 1)))
+	  (is (= (count "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe"
+			objects :test #'string=) 1))
+	  (is (= (count "von Goethe" objects :test #'string=) 1))
+	  (is (= (count "Johann Wolfgang" objects :test #'string=) 1))
+	  (is (= (count "http://some.where/psis/region/frankfurt_am_main"
+			objects :test #'string=) 1)))
+	(is-true (or (null (set-exclusive-or
+			    (list "http://some.where/psis/poem/der_zauberlehrling")
+			    (tm-sparql::subject-result
+			     (first (tm-sparql::select-group q-obj-2)))
+			    :test #'string=))
+		     (null (set-exclusive-or
+			    (list "http://some.where/psis/poem/zauberlehrling")
+			    (tm-sparql::subject-result
+			     (first (tm-sparql::select-group q-obj-2)))
+			    :test #'string=))))
+	(let ((predicates (tm-sparql::predicate-result
+			   (first (tm-sparql::select-group q-obj-2)))))
+	  (is (= (count "http://some.where/base-psis/writer" predicates
+			:test #'string=) 1))
+	  (is (= (count "http://some.where/base-psis/title" predicates
+			:test #'string=) 1))
+	  (is (= (count "http://some.where/base-psis/poem-content" predicates
+			:test #'string=) 1))
+	  (is (= (count "http://psi.topicmaps.org/iso13250/model/type" predicates
+			:test #'string=) 1)))
+	(let ((objects (tm-sparql::object-result
+			(first (tm-sparql::select-group q-obj-2)))))
+	  (is (or (= (count "http://some.where/psis/author/goethe" objects
+			    :test #'string=) 1)
+		  (= (count "http://some.where/psis/persons/goethe" objects
+			    :test #'string=) 1)))
+	  (is (= (count "Der Zauberlehrling" objects :test #'string=) 1))
+	  (is (= (count "http://some.where/base-psis/poem"
+			objects :test #'string=) 1))
+	  ;do not check the entire poem content => too long
+	  )
+	(is (or (string= "http://some.where/psis/author/goethe"
+			 (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-3)))))
+		(string= "http://some.where/psis/persons/goethe"
+			 (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-3)))))))
+	(is (string= "http://some.where/base-psis/written"
+		     (first (tm-sparql::predicate-result
+			     (first (tm-sparql::select-group q-obj-3))))))
+	(is (or (string= "http://some.where/psis/poem/der_zauberlehrling"
+			 (first (tm-sparql::object-result
+				 (first (tm-sparql::select-group q-obj-3)))))
+		(string= "http://some.where/psis/poem/zauberlehrling"
+			 (first (tm-sparql::object-result
+				 (first (tm-sparql::select-group q-obj-3)))))))))))
+
+
+(test test-set-result-5
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let* ((query-1 "BASE <http://some.where/>
+                       SELECT ?predicate WHERE {
+                         <psis/author/goethe> ?predicate 'Johann Wolfgang'}")
+	     (query-2 "BASE <http://some.where/>
+                       SELECT ?object WHERE {
+                         <psis/author/goethe> <base-psis/written> ?object}")
+	     (query-3 "BASE <http://some.where/>
+                       SELECT ?object WHERE {
+                         <psis/persons/goethe> <base-psis/last-name> ?object.
+                         <does/not/exist> <any-predicate> ?object}")
+	     (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))
+	     (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))
+	     (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3)))
+	(is-true q-obj-1)
+	(is-true q-obj-2)
+	(is-true q-obj-3)
+	(is (= (length (tm-sparql::select-group q-obj-1)) 1))
+	(is (= (length (tm-sparql::select-group q-obj-2)) 1))
+	(is (= (length (tm-sparql::select-group q-obj-3)) 2))
+	(is (= (length (tm-sparql::subject-result
+			(first (tm-sparql::select-group q-obj-1)))) 1))
+	(is (= (length (tm-sparql::subject-result
+			(first (tm-sparql::select-group q-obj-2)))) 2))
+	(is (= (length (tm-sparql::subject-result
+			(first (tm-sparql::select-group q-obj-3)))) 0))
+	(is (= (length (tm-sparql::subject-result
+			(second (tm-sparql::select-group q-obj-3)))) 1))
+	(is (or (string= "http://some.where/psis/author/goethe"
+			 (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-1)))))
+		(string= "http://some.where/psis/persons/goethe"
+			 (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-1)))))))
+	(is (string= "http://some.where/base-psis/first-name"
+		     (first (tm-sparql::predicate-result
+			     (first (tm-sparql::select-group q-obj-1))))))
+	(is (string= "Johann Wolfgang"
+		     (first (tm-sparql::object-result
+			     (first (tm-sparql::select-group q-obj-1))))))
+	(is (or (string= "http://some.where/psis/author/goethe"
+			 (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-2)))))
+		(string= "http://some.where/psis/persons/goethe"
+			 (first (tm-sparql::subject-result
+				 (first (tm-sparql::select-group q-obj-2)))))))
+	(is (string= "http://some.where/base-psis/written"
+		     (first (tm-sparql::predicate-result
+			     (first (tm-sparql::select-group q-obj-2))))))
+	(is (or (string= "http://some.where/psis/poem/zauberlehrling"
+			 (first (tm-sparql::object-result
+				 (first (tm-sparql::select-group q-obj-2)))))
+		(string= "http://some.where/psis/poem/der_zauberlehrling"
+			 (first (tm-sparql::object-result
+				 (first (tm-sparql::select-group q-obj-2)))))
+		(string= "http://some.where/psis/poem/erlkoenig"
+			 (first (tm-sparql::object-result
+				 (first (tm-sparql::select-group q-obj-2)))))))
+	(is (or (string= "http://some.where/psis/author/goethe"
+			 (second (tm-sparql::subject-result
+				  (first (tm-sparql::select-group q-obj-2)))))
+		(string= "http://some.where/psis/persons/goethe"
+			 (second (tm-sparql::subject-result
+				  (first (tm-sparql::select-group q-obj-2)))))))
+	(is (string= "http://some.where/base-psis/written"
+		     (second (tm-sparql::predicate-result
+			      (first (tm-sparql::select-group q-obj-2))))))
+	(is (or (string= "http://some.where/psis/poem/zauberlehrling"
+			 (second (tm-sparql::object-result
+				  (first (tm-sparql::select-group q-obj-2)))))
+		(string= "http://some.where/psis/poem/der_zauberlehrling"
+			 (second (tm-sparql::object-result
+				  (first (tm-sparql::select-group q-obj-2)))))
+		(string= "http://some.where/psis/poem/erlkoenig"
+			 (second (tm-sparql::object-result
+				  (first (tm-sparql::select-group q-obj-2)))))))
+	(is-false (first (tm-sparql::subject-result
+			  (first (tm-sparql::select-group q-obj-3)))))
+	(is-false (first (tm-sparql::predicate-result
+			  (first (tm-sparql::select-group q-obj-3)))))
+	(is-false (first (tm-sparql::object-result
+			  (first (tm-sparql::select-group q-obj-3)))))
+	(is (or (string= "http://some.where/psis/author/goethe"
+			 (first (tm-sparql::subject-result
+				 (second (tm-sparql::select-group q-obj-3)))))
+		(string= "http://some.where/psis/persons/goethe"
+			 (first (tm-sparql::subject-result
+				 (second (tm-sparql::select-group q-obj-3)))))))
+	(is (string= "http://some.where/base-psis/last-name"
+		     (first (tm-sparql::predicate-result
+			     (second (tm-sparql::select-group q-obj-3))))))
+	(is (string= "von Goethe"
+		     (first (tm-sparql::object-result
+			     (second (tm-sparql::select-group q-obj-3))))))))))
 
 
 (defun run-sparql-tests ()



From lgiessmann at common-lisp.net  Sat Dec  4 13:59:08 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 04 Dec 2010 08:59:08 -0500
Subject: [isidorus-cvs] r358 - in trunk/src: TM-SPARQL rest_interface
	unit_tests
Message-ID: <E1POsdo-0007c6-Ee@common-lisp.net>

Author: lgiessmann
Date: Sat Dec  4 08:59:08 2010
New Revision: 358

Log:
TM-SPARQL: added a method called "result"=>SPARQL-Query, so invoking it produces a result of the entier query; fixed a style warning in the RESTful-itnerface

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/rest_interface/set-up-json-interface.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Sat Dec  4 08:59:08 2010
@@ -9,10 +9,8 @@
 
 (defpackage :TM-SPARQL
   (:use :cl :datamodel :base-tools :exceptions :constants)
-  (:export :SPARQL-Query))
-
-;;TODO:
-;; *handle special URIs => http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html
+  (:export :SPARQL-Query
+	   :result))
 
 (in-package :TM-SPARQL)
 
@@ -161,6 +159,21 @@
   (:documentation "This class represents the entire request."))
 
 
+(defmethod variables ((construct SPARQL-Triple-Elem))
+  "Returns all variable names that are contained in the passed element."
+  (remove-duplicates
+   (remove-null
+    (loop for triple in (select-group construct)
+       collect (remove-null
+		(list (when (variable-p (subject construct))
+			(value (subject construct)))
+		      (when (variable-p (predicate construct))
+			(value (predicate construct)))
+		      (when (variable-p (object construct))
+		       (value (object construct)))))))
+   :test #'string=))
+
+
 (defgeneric add-triple (construct triple)
   (:documentation "Adds a triple object to the select-group list.")
   (:method ((construct SPARQL-Query) (triple SPARQL-Triple))
@@ -742,6 +755,162 @@
 	    assocs)))))
 
 
+
+(defgeneric result (construct)
+  (:documentation "Returns the result of the entire query.")
+  (:method ((construct SPARQL-Query))
+    (let ((result-lists (make-result-lists construct)))
+      (reduce-results construct result-lists)
+      (let* ((response-variables (variables construct))
+	     (cleaned-results (make-result-lists construct)))
+	(map 'list #'(lambda(response-variable)
+		       (variable-intersection response-variable
+					      cleaned-results))
+	     response-variables)))))
+
+
+(defgeneric make-result-lists (construct)
+  (:documentation "Returns a list of the form ((:variable 'var-name'
+                   :result (<any-object>)).")
+  (:method ((construct SPARQL-Query))
+    (remove-null
+     (loop for triple in (select-group construct)
+	collect (remove-null
+		 (list
+		  (when (variable-p (subject construct))
+		    (list :variable (value (subject construct))
+			  :result (subject-result construct)))
+		  (when (variable-p (predicate construct))
+		    (list :variable (value (predicate construct))
+			  :result (predicate-result construct)))
+		  (when (variable-p (object construct))
+		    (list :variable (value (object construct))
+			  :result (object-result construct)))))))))
+
+
+(defgeneric all-variables (result-lists)
+  (:documentation "Returns a list of all variables that are contained in
+                   the passed result-lists.")
+  (:method ((result-lists List))
+    (remove-duplicates
+     (map 'list #'(lambda(entry)
+		    (getf entry :variable))
+	  result-lists)
+     :test #'string=)))
+
+
+(defgeneric variable-intersection (variable-name result-lists)
+  (:documentation "Returns a list with all results of the passed variable
+                   that are contained in the result-lists. All results is
+                   an intersection of all paratial results.")
+  (:method ((variable-name String) (result-lists List))
+    (let* ((all-values (results-for-variable variable-name result-lists))
+	   (list-1 (when (>= (length all-values) 1)
+		     (first all-values)))
+	   (list-2 (if (> (length all-values) 2)
+		       (second all-values)
+		       list-1))
+	   (more-lists (rest (rest all-values))))
+      (recursive-intersection list-1 list-2 more-lists))))
+
+
+(defun recursive-intersection (list-1 list-2 &rest more-lists)
+  "Returns an intersection of al the passed lists."
+  (declare (List list-1 list-2))
+  (let ((current-result
+	 (intersection list-1 list-2
+		       :test #'(lambda(val-1 val-2)
+				 (if (and (stringp val-1) (stringp val-2))
+				     (string= val-1 val-2)
+				     (eql val-1 val-2))))))
+    (if (= (length more-lists) 0)
+	current-result
+	(apply #'recursive-intersection current-result
+	       (first more-lists) (rest more-lists)))))
+
+
+(defgeneric reduce-results(construct result-lists)
+  (:documentation "Reduces the select-group of the passed construct by processing
+                   all triples with the intersection-results.")
+  (:method ((construct SPARQL-Query) (result-lists List))
+    (map 'list #'(lambda(triple)
+		   (reduce-triple triple result-lists))
+	 (select-group construct))))
+
+
+(defgeneric reduce-triple(construct result-lists)
+  (:documentation "Reduces the results of a triple by using only the
+                   intersection values.")
+  (:method ((construct SPARQL-Triple-Elem) (result-lists List))
+    (let* ((triple-variables (variables construct))
+	   (intersections
+	    (map 'list #'(lambda(var)
+			   (list :variable var
+				 :result (variable-intersection
+					  var result-lists)))
+		 triple-variables)))
+      (map 'list #'(lambda(entry)
+		     (delete-rows construct (getf entry :variable)
+				  (getf entry :result)))
+	   intersections))))
+
+
+(defgeneric delete-rows (construct variable-name dont-touch-values)
+  (:documentation "Checks all results of the passed variable of the given
+                   construct and deletes every result with the corresponding
+                   row that is not contained in the dont-touch-values.")
+  (:method ((construct SPARQL-Triple-Elem) (variable-name String)
+	    (dont-touch-values List))
+    (let ((var-elem
+	   (cond ((and (variable-p (subject construct))
+		       (string= (value (subject construct)) variable-name))
+		  (subject-result construct))
+		 ((and (variable-p (predicate construct))
+		       (string= (value (predicate construct)) variable-name))
+		  (predicate-result construct))
+		 ((and (variable-p (object construct))
+		       (string= (value (object construct)) variable-name))
+		  (object-result construct)))))
+      (if (not var-elem)
+	  construct
+	  (let* ((rows-to-hold
+		  (remove-null
+		   (map 'list #'(lambda(val)
+				  (if (stringp val)
+				      (position val var-elem :test #'string=)
+				      (position val var-elem)))
+			var-elem)))
+		 (new-result-list
+		  (dolist (row-idx rows-to-hold)
+		    (list :subject (elt (subject-result construct) row-idx)
+			  :predicate (elt (predicate-result construct) row-idx)
+			  :object (elt (object-result construct) row-idx)))))
+	    (setf (subject-result construct)
+		  (map 'list #'(lambda(entry)
+				 (getf entry :subject)) new-result-list))
+	    (setf (predicate-result construct)
+		  (map 'list #'(lambda(entry)
+				 (getf entry :predicate)) new-result-list))
+	    (setf (object-result construct)
+		  (map 'list #'(lambda(entry)
+				 (getf entry :object)) new-result-list)))))))
+
+
+(defgeneric results-for-variable (variable-name result-lists)
+  (:documentation "Returns a list with result-lists for the passed variable.")
+  (:method ((variable-name String) (result-lists List))
+    (let* ((cleaned-result-lists
+	    (remove-if-not #'(lambda(entry)
+			       (string= (getf entry :variable)
+					variable-name))
+			   result-lists))
+	   (values
+	    (map 'list #'(lambda(entry)
+			   (getf entry :result))
+		 cleaned-result-lists)))
+      values)))
+
+
 (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args)
   (declare (ignorable args))
   (parser-start construct (original-query construct))

Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp	(original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp	Sat Dec  4 08:59:08 2010
@@ -428,8 +428,10 @@
 		    (if result
 			(progn
 			  (when (typep result 'd:TopicC)
-			    (delete (elephant::oid result) *type-table*)
-			    (delete (elephant::oid result) *instance-table*))
+			    (append ;;the append function is used only for suppress
+			            ;;style warnings of unused delete return values
+			     (delete (elephant::oid result) *type-table*)
+			     (delete (elephant::oid result) *instance-table*)))
 			  (format nil "")) ;operation succeeded
 			(progn
 			  (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Sat Dec  4 08:59:08 2010
@@ -19,6 +19,7 @@
   (:export :run-sparql-tests
 	   :sparql-tests
 	   :test-prefix-and-base
+	   :test-variable-names
 	   :test-parse-literals
 	   :test-parse-triple-elem
 	   :test-parse-group-1
@@ -180,61 +181,61 @@
 	(query-9 (concatenate 'string "\"13e4\"^^" *xml-boolean* " ."))
 	(dummy-object (make-instance 'SPARQL-Query :query "")))
     (is-true dummy-object)
-    (let ((result (tm-sparql::parse-literal-elem query-1 dummy-object)))
-      (is (string= (getf result :next-query) "."))
-      (is (string= (tm-sparql::value (getf result :value))
+    (let ((res (tm-sparql::parse-literal-elem query-1 dummy-object)))
+      (is (string= (getf res :next-query) "."))
+      (is (string= (tm-sparql::value (getf res :value))
 		   "literal-value"))
-      (is (string= (tm-sparql::literal-lang (getf result :value))
+      (is (string= (tm-sparql::literal-lang (getf res :value))
 		   "de"))
-      (is (string= (tm-sparql::literal-datatype (getf result :value))
+      (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-string*))
-      (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
-    (let ((result (tm-sparql::parse-literal-elem query-2 dummy-object)))
-      (is (string= (getf result :next-query) "."))
-      (is (eql (tm-sparql::value (getf result :value)) t))
-      (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-datatype (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
+    (let ((res (tm-sparql::parse-literal-elem query-2 dummy-object)))
+      (is (string= (getf res :next-query) "."))
+      (is (eql (tm-sparql::value (getf res :value)) t))
+      (is-false (tm-sparql::literal-lang (getf res :value)))
+      (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-boolean*))
-      (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
-    (let ((result (tm-sparql::parse-literal-elem query-3 dummy-object)))
-      (is (string= (getf result :next-query) "}"))
-      (is (eql (tm-sparql::value (getf result :value)) nil))
-      (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-datatype (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
+    (let ((res (tm-sparql::parse-literal-elem query-3 dummy-object)))
+      (is (string= (getf res :next-query) "}"))
+      (is (eql (tm-sparql::value (getf res :value)) nil))
+      (is-false (tm-sparql::literal-lang (getf res :value)))
+      (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-boolean*))
-      (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
-    (let ((result (tm-sparql::parse-literal-elem query-4 dummy-object)))
-      (is (string= (getf result :next-query) (string #\tab)))
-      (is (= (tm-sparql::value (getf result :value)) 1234.43e10))
-      (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-datatype (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
+    (let ((res (tm-sparql::parse-literal-elem query-4 dummy-object)))
+      (is (string= (getf res :next-query) (string #\tab)))
+      (is (= (tm-sparql::value (getf res :value)) 1234.43e10))
+      (is-false (tm-sparql::literal-lang (getf res :value)))
+      (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-double*))
-      (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
-    (let ((result (tm-sparql::parse-literal-elem query-5 dummy-object)))
-      (is (string= (getf result :next-query) ";"))
-      (is (eql (tm-sparql::value (getf result :value)) t))
-      (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-datatype (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
+    (let ((res (tm-sparql::parse-literal-elem query-5 dummy-object)))
+      (is (string= (getf res :next-query) ";"))
+      (is (eql (tm-sparql::value (getf res :value)) t))
+      (is-false (tm-sparql::literal-lang (getf res :value)))
+      (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-boolean*))
-      (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
-    (let ((result (tm-sparql::parse-literal-elem query-6 dummy-object)))
-      (is (string= (getf result :next-query)
+      (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
+    (let ((res (tm-sparql::parse-literal-elem query-6 dummy-object)))
+      (is (string= (getf res :next-query)
 		   (concatenate 'string "." (string #\newline))))
-      (is (eql (tm-sparql::value (getf result :value)) 123.4))
-      (is-false (tm-sparql::literal-lang (getf result :value)))
-      (is (string= (tm-sparql::literal-datatype (getf result :value))
+      (is (eql (tm-sparql::value (getf res :value)) 123.4))
+      (is-false (tm-sparql::literal-lang (getf res :value)))
+      (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-double*))
-      (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
-    (let ((result (tm-sparql::parse-literal-elem query-7 dummy-object)))
-      (is (string= (getf result :next-query) "."))
-      (is (string= (tm-sparql::value (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
+    (let ((res (tm-sparql::parse-literal-elem query-7 dummy-object)))
+      (is (string= (getf res :next-query) "."))
+      (is (string= (tm-sparql::value (getf res :value))
 		   "Just a test
 
 literal with some \\\"quoted\\\" words!"))
-      (is (string= (tm-sparql::literal-lang (getf result :value)) "en"))
-      (is (string= (tm-sparql::literal-datatype (getf result :value))
+      (is (string= (tm-sparql::literal-lang (getf res :value)) "en"))
+      (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-string*))
-      (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL)))
+      (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
     (signals sparql-parser-error
       (tm-sparql::parse-literal-elem query-8 dummy-object))
     (signals sparql-parser-error
@@ -256,38 +257,38 @@
 	(var 'TM-SPARQL::VARIABLE)
 	(iri 'TM-SPARQL::IRI))
     (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value")
-    (let ((result (tm-sparql::parse-triple-elem query-1 dummy-object)))
-      (is (string= (getf result :next-query) "."))
-      (is (string= (tm-sparql::value (getf result :value)) "var1"))
-      (is (eql (tm-sparql::elem-type (getf result :value)) var)))
-    (let ((result (tm-sparql::parse-triple-elem query-2 dummy-object)))
-      (is (string= (getf result :next-query) ";"))
-      (is (string= (tm-sparql::value (getf result :value)) "var2"))
-      (is (eql (tm-sparql::elem-type (getf result :value)) var)))
-    (let ((result (tm-sparql::parse-triple-elem query-3 dummy-object)))
-      (is (string= (getf result :next-query) "}"))
-      (is (string= (tm-sparql::value (getf result :value)) "var3"))
-      (is (eql (tm-sparql::elem-type (getf result :value)) var)))
-    (let ((result (tm-sparql::parse-triple-elem query-4 dummy-object)))
-      (is (string= (getf result :next-query) "."))
-      (is (string= (tm-sparql::value (getf result :value))
+    (let ((res (tm-sparql::parse-triple-elem query-1 dummy-object)))
+      (is (string= (getf res :next-query) "."))
+      (is (string= (tm-sparql::value (getf res :value)) "var1"))
+      (is (eql (tm-sparql::elem-type (getf res :value)) var)))
+    (let ((res (tm-sparql::parse-triple-elem query-2 dummy-object)))
+      (is (string= (getf res :next-query) ";"))
+      (is (string= (tm-sparql::value (getf res :value)) "var2"))
+      (is (eql (tm-sparql::elem-type (getf res :value)) var)))
+    (let ((res (tm-sparql::parse-triple-elem query-3 dummy-object)))
+      (is (string= (getf res :next-query) "}"))
+      (is (string= (tm-sparql::value (getf res :value)) "var3"))
+      (is (eql (tm-sparql::elem-type (getf res :value)) var)))
+    (let ((res (tm-sparql::parse-triple-elem query-4 dummy-object)))
+      (is (string= (getf res :next-query) "."))
+      (is (string= (tm-sparql::value (getf res :value))
 		   "http://full.url"))
-      (is (eql (tm-sparql::elem-type (getf result :value)) iri)))
-    (let ((result (tm-sparql::parse-triple-elem query-5 dummy-object)))
-      (is (string= (getf result :next-query) "}"))
-      (is (string= (tm-sparql::value (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
+    (let ((res (tm-sparql::parse-triple-elem query-5 dummy-object)))
+      (is (string= (getf res :next-query) "}"))
+      (is (string= (tm-sparql::value (getf res :value))
 		   "http://base.value/url-suffix"))
-      (is (eql (tm-sparql::elem-type (getf result :value)) iri)))
-    (let ((result (tm-sparql::parse-triple-elem query-6 dummy-object)))
-      (is (string= (getf result :next-query) "."))
-      (is (string= (tm-sparql::value (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
+    (let ((res (tm-sparql::parse-triple-elem query-6 dummy-object)))
+      (is (string= (getf res :next-query) "."))
+      (is (string= (tm-sparql::value (getf res :value))
 		   "http://prefix.value/suffix"))
-      (is (eql (tm-sparql::elem-type (getf result :value)) iri)))
-    (let ((result (tm-sparql::parse-triple-elem query-7 dummy-object)))
-      (is (string= (getf result :next-query) "}"))
-      (is (string= (tm-sparql::value (getf result :value))
+      (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
+    (let ((res (tm-sparql::parse-triple-elem query-7 dummy-object)))
+      (is (string= (getf res :next-query) "}"))
+      (is (string= (tm-sparql::value (getf res :value))
 		   "http://prefix.value/suffix"))
-      (is (eql (tm-sparql::elem-type (getf result :value)) iri)))
+      (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
     (signals sparql-parser-error 
       (tm-sparql::parse-triple-elem query-8 dummy-object))))
 



From lgiessmann at common-lisp.net  Sat Dec  4 17:07:46 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 04 Dec 2010 12:07:46 -0500
Subject: [isidorus-cvs] r359 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1POvaM-0005YV-F2@common-lisp.net>

Author: lgiessmann
Date: Sat Dec  4 12:07:46 2010
New Revision: 359

Log:
TM-SPARQL: added unit-tests for the "result"=>SPARQL-Query method => fixed some bugs

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Sat Dec  4 12:07:46 2010
@@ -132,9 +132,8 @@
 					;purposes and mustn't be reset
 	      :type List
 	      :initform nil
-	      :documentation "A list of the form ((:variable var-name
-                             :value value-object)), that contains tuples
-                             for each selected variable and its result.")
+	      :documentation "A list of the form that contains the variable
+                              names as string.")
    (prefixes :initarg :prefixes
 	     :accessor prefixes ;this value is only for internal purposes
 			        ;purposes and mustn't be reset
@@ -159,18 +158,23 @@
   (:documentation "This class represents the entire request."))
 
 
-(defmethod variables ((construct SPARQL-Triple-Elem))
+(defgeneric *-p (construct)
+  (:documentation "Returns t if the user selected all variables with *.")
+  (:method ((construct SPARQL-Query))
+    (and (= (length (variables construct)) 1)
+	 (string= (first (variables construct)) "*"))))
+
+
+(defmethod variables ((construct SPARQL-Triple))
   "Returns all variable names that are contained in the passed element."
   (remove-duplicates
    (remove-null
-    (loop for triple in (select-group construct)
-       collect (remove-null
-		(list (when (variable-p (subject construct))
-			(value (subject construct)))
-		      (when (variable-p (predicate construct))
-			(value (predicate construct)))
-		      (when (variable-p (object construct))
-		       (value (object construct)))))))
+    (list (when (variable-p (subject construct))
+	    (value (subject construct)))
+	  (when (variable-p (predicate construct))
+	    (value (predicate construct)))
+	  (when (variable-p (object construct))
+	    (value (object construct)))))
    :test #'string=))
 
 
@@ -222,20 +226,14 @@
 			     (concatenate 'string (getf entry :label) ":"))))))
 
 
-(defgeneric add-variable (construct variable-name variable-value)
+(defgeneric add-variable (construct variable-name)
   (:documentation "Adds a new variable-name with its value to the aexisting list.
                    If a variable-already exists the existing entry will be
                    overwritten. An entry is of the form
                    (:variable string :value any-type).")
-  (:method ((construct SPARQL-Query) (variable-name String) variable-value)
-    (let ((existing-tuple
-	   (find-if #'(lambda(x)
-			(string= (getf x :variable) variable-name))
-		    (variables construct))))
-      (if existing-tuple
-	  (setf (getf existing-tuple :value) variable-value)
-	  (push (list :variable variable-name :value variable-value)
-		(variables construct))))))
+  (:method ((construct SPARQL-Query) (variable-name String))
+    (unless (find variable-name (variables construct) :test #'string=)
+      (push variable-name (variables construct)))))
 
 
 (defgeneric set-results (construct &key revision)
@@ -755,17 +753,20 @@
 	    assocs)))))
 
 
-
 (defgeneric result (construct)
   (:documentation "Returns the result of the entire query.")
   (:method ((construct SPARQL-Query))
     (let ((result-lists (make-result-lists construct)))
       (reduce-results construct result-lists)
-      (let* ((response-variables (variables construct))
+      (let* ((response-variables
+	      (if (*-p construct)
+		  (all-variables construct)
+		  (variables construct)))
 	     (cleaned-results (make-result-lists construct)))
 	(map 'list #'(lambda(response-variable)
-		       (variable-intersection response-variable
-					      cleaned-results))
+		       (list :variable response-variable
+			     :result (variable-intersection response-variable
+							    cleaned-results)))
 	     response-variables)))))
 
 
@@ -775,28 +776,39 @@
   (:method ((construct SPARQL-Query))
     (remove-null
      (loop for triple in (select-group construct)
-	collect (remove-null
-		 (list
-		  (when (variable-p (subject construct))
-		    (list :variable (value (subject construct))
-			  :result (subject-result construct)))
-		  (when (variable-p (predicate construct))
-		    (list :variable (value (predicate construct))
-			  :result (predicate-result construct)))
-		  (when (variable-p (object construct))
-		    (list :variable (value (object construct))
-			  :result (object-result construct)))))))))
+	append (remove-null
+		(list
+		 (when (variable-p (subject triple))
+		   (list :variable (value (subject triple))
+			 :result (subject-result triple)))
+		 (when (variable-p (predicate triple))
+		   (list :variable (value (predicate triple))
+			  :result (predicate-result triple)))
+		 (when (variable-p (object triple))
+		   (list :variable (value (object triple))
+			 :result (object-result triple)))))))))
 
 
 (defgeneric all-variables (result-lists)
   (:documentation "Returns a list of all variables that are contained in
-                   the passed result-lists.")
-  (:method ((result-lists List))
-    (remove-duplicates
-     (map 'list #'(lambda(entry)
-		    (getf entry :variable))
-	  result-lists)
-     :test #'string=)))
+                   the passed result-lists."))
+
+
+(defmethod all-variables ((result-lists List))
+  (remove-duplicates
+   (map 'list #'(lambda(entry)
+		  (getf entry :variable))
+	result-lists)
+   :test #'string=))
+
+
+(defmethod all-variables ((construct SPARQL-Query))
+  "Returns all variables that are contained in the select groupt memebers."
+  (remove-duplicates
+   (remove-null
+    (loop for triple in (select-group construct)
+       append (variables triple)))
+   :test #'string=))
 
 
 (defgeneric variable-intersection (variable-name result-lists)
@@ -814,7 +826,7 @@
       (recursive-intersection list-1 list-2 more-lists))))
 
 
-(defun recursive-intersection (list-1 list-2 &rest more-lists)
+(defun recursive-intersection (list-1 list-2 more-lists)
   "Returns an intersection of al the passed lists."
   (declare (List list-1 list-2))
   (let ((current-result
@@ -823,10 +835,10 @@
 				 (if (and (stringp val-1) (stringp val-2))
 				     (string= val-1 val-2)
 				     (eql val-1 val-2))))))
-    (if (= (length more-lists) 0)
+    (if (not more-lists)
 	current-result
-	(apply #'recursive-intersection current-result
-	       (first more-lists) (rest more-lists)))))
+	(recursive-intersection current-result (first more-lists)
+				(rest more-lists)))))
 
 
 (defgeneric reduce-results(construct result-lists)
@@ -841,7 +853,7 @@
 (defgeneric reduce-triple(construct result-lists)
   (:documentation "Reduces the results of a triple by using only the
                    intersection values.")
-  (:method ((construct SPARQL-Triple-Elem) (result-lists List))
+  (:method ((construct SPARQL-Triple) (result-lists List))
     (let* ((triple-variables (variables construct))
 	   (intersections
 	    (map 'list #'(lambda(var)
@@ -859,7 +871,7 @@
   (:documentation "Checks all results of the passed variable of the given
                    construct and deletes every result with the corresponding
                    row that is not contained in the dont-touch-values.")
-  (:method ((construct SPARQL-Triple-Elem) (variable-name String)
+  (:method ((construct SPARQL-Triple) (variable-name String)
 	    (dont-touch-values List))
     (let ((var-elem
 	   (cond ((and (variable-p (subject construct))
@@ -871,29 +883,30 @@
 		 ((and (variable-p (object construct))
 		       (string= (value (object construct)) variable-name))
 		  (object-result construct)))))
-      (if (not var-elem)
-	  construct
-	  (let* ((rows-to-hold
-		  (remove-null
-		   (map 'list #'(lambda(val)
-				  (if (stringp val)
-				      (position val var-elem :test #'string=)
-				      (position val var-elem)))
-			var-elem)))
-		 (new-result-list
-		  (dolist (row-idx rows-to-hold)
-		    (list :subject (elt (subject-result construct) row-idx)
-			  :predicate (elt (predicate-result construct) row-idx)
-			  :object (elt (object-result construct) row-idx)))))
-	    (setf (subject-result construct)
-		  (map 'list #'(lambda(entry)
-				 (getf entry :subject)) new-result-list))
-	    (setf (predicate-result construct)
-		  (map 'list #'(lambda(entry)
-				 (getf entry :predicate)) new-result-list))
-	    (setf (object-result construct)
-		  (map 'list #'(lambda(entry)
-				 (getf entry :object)) new-result-list)))))))
+      (when var-elem
+	(let* ((rows-to-hold
+		(remove-null
+		 (map 'list #'(lambda(val)
+				(if (stringp val)
+				    (position val var-elem :test #'string=)
+				    (position val var-elem)))
+		      dont-touch-values)))
+	       (new-result-list
+		(map 'list
+		     #'(lambda(row-idx)
+			 (list :subject (elt (subject-result construct) row-idx)
+			       :predicate (elt (predicate-result construct) row-idx)
+			       :object (elt (object-result construct) row-idx)))
+		     rows-to-hold)))
+	  (setf (subject-result construct)
+		(map 'list #'(lambda(entry)
+			       (getf entry :subject)) new-result-list))
+	  (setf (predicate-result construct)
+		(map 'list #'(lambda(entry)
+			       (getf entry :predicate)) new-result-list))
+	  (setf (object-result construct)
+		(map 'list #'(lambda(entry)
+			       (getf entry :object)) new-result-list)))))))
 
 
 (defgeneric results-for-variable (variable-name result-lists)

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Sat Dec  4 12:07:46 2010
@@ -163,7 +163,7 @@
 	   (list :next-query (cut-comment (subseq trimmed-str 1))
 		 :value (make-instance 'SPARQL-Triple-Elem
 				       :elem-type 'IRI
-				       :value *rdf-type*)))
+				       :value *type-psi*)))
 	  ((string-starts-with trimmed-str "<")
 	   (parse-base-suffix-pair trimmed-str query-object))
 	  ((or (string-starts-with trimmed-str "?")
@@ -484,10 +484,10 @@
       (if (string-starts-with trimmed-str "WHERE")
 	  trimmed-str
 	  (if (string-starts-with trimmed-str "*")
-	      (progn (add-variable construct "*" nil)
+	      (progn (add-variable construct "*")
 		     (parse-variables construct (string-after trimmed-str "*")))
 	      (let ((result (parse-variable-name trimmed-str construct)))
-		(add-variable construct (getf result :value) nil)
+		(add-variable construct (getf result :value))
 		(parse-variables construct (getf result :next-query))))))))
 
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Sat Dec  4 12:07:46 2010
@@ -28,7 +28,8 @@
 	   :test-set-result-2
 	   :test-set-result-3
 	   :test-set-result-4
-	   :test-set-result-5))
+	   :test-set-result-5
+	   :test-result))
 
 
 (in-package :sparql-test)
@@ -134,35 +135,22 @@
     (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)
-			  (and (string= (getf elem :variable) "var1")
-			       (null (getf elem :value))))
-		      (TM-SPARQL::variables query-object-1)))
-    (is-true (find-if #'(lambda(elem)
-			  (and (string= (getf elem :variable) "var2")
-			       (null (getf elem :value))))
-		      (TM-SPARQL::variables query-object-1)))
-    (is-true (find-if #'(lambda(elem)
-			  (and (string= (getf elem :variable) "var3")
-			       (null (getf elem :value))))
-		      (TM-SPARQL::variables query-object-1)))
+    (is-true (find "var1" (TM-SPARQL::variables query-object-1)
+		   :test #'string=))
+    (is-true (find "var2" (TM-SPARQL::variables query-object-1)
+		   :test #'string=))
+    (is-true (find "var3" (TM-SPARQL::variables query-object-1)
+		   :test #'string=))
     (is (= (length (TM-SPARQL::variables query-object-2)) 3))
-    (is-true (find-if #'(lambda(elem)
-			  (and (string= (getf elem :variable) "var1")
-			       (null (getf elem :value))))
-		      (TM-SPARQL::variables query-object-2)))
-    (is-true (find-if #'(lambda(elem)
-			  (and (string= (getf elem :variable) "var2")
-			       (null (getf elem :value))))
-		      (TM-SPARQL::variables query-object-2)))
-    (is-true (find-if #'(lambda(elem)
-			  (and (string= (getf elem :variable) "var3")
-			       (null (getf elem :value))))
-		      (TM-SPARQL::variables query-object-2)))
-    (is-true (find-if #'(lambda(elem)
-			  (and (string= (getf elem :variable) "*")
-			       (null (getf elem :value))))
-		      (TM-SPARQL::variables query-object-3)))))
+    (is-true (find "var1" (TM-SPARQL::variables query-object-2)
+		   :test #'string=))
+    (is-true (find "var2" (TM-SPARQL::variables query-object-2)
+		   :test #'string=))
+    (is-true (find "var3" (TM-SPARQL::variables query-object-2)
+		   :test #'string=))
+    (is-true (find "*" (TM-SPARQL::variables query-object-3)
+		   :test #'string=))
+    (is-true (tm-sparql::*-p query-object-3))))
 
 
 (test test-parse-literals
@@ -940,5 +928,117 @@
 			     (second (tm-sparql::select-group q-obj-3))))))))))
 
 
+(test test-result
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let* ((query-1 "PREFIX author:<http://some.where/psis/author/>
+                     PREFIX poem:<http://some.where/psis/poem/>
+                     PREFIX basePSIs:<http://some.where/base-psis/>
+                     SELECT ?poems ?poets WHERE {
+                         ?poets a basePSIs:author .
+                         ?poets basePSIs:written ?poems.
+                         ?poems basePSIs:title 'Der Erlk?nig' .
+                         ?poems a basePSIs:poem}")
+	     (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))
+	     (query-2 "PREFIX author:<http://some.where/psis/author/>
+                     PREFIX poem:<http://some.where/psis/poem/>
+                     PREFIX basePSIs:<http://some.where/base-psis/>
+                     SELECT * WHERE {
+                         ?poems a basePSIs:poem.
+                         <goethe> <last-name> 'von Goethe' .
+                         ?poems basePSIs:title ?titles}")
+	     (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)))
+	(is-true q-obj-1)
+	(is-true q-obj-2)
+	(is (= (length (tm-sparql::select-group q-obj-1)) 4))
+	(is (= (length (tm-sparql::select-group q-obj-2)) 3))
+	(is (= (length (result q-obj-1)) 2))
+	(if (string= (getf (first (result q-obj-1)) :variable) "poets")
+	    (progn
+	      (is (= (length (getf (first (result q-obj-1)) :result)) 1))
+	      (is (or (string= (first (getf (first (result q-obj-1)) :result))
+			       "http://some.where/psis/author/goethe")
+		      (string= (first (getf (first (result q-obj-1)) :result))
+			       "http://some.where/psis/persons/goethe")))
+	      (is (= (length (getf (second (result q-obj-1)) :result)) 1))
+	      (is (string= (first (getf (second (result q-obj-1)) :result))
+			   "http://some.where/psis/poem/erlkoenig"))
+	      (is (string= (getf (second (result q-obj-1)) :variable) "poems")))
+	    (progn
+	      (is (= (length (getf (second (result q-obj-1)) :result)) 1))
+	      (is (or (string= (first (getf (second (result q-obj-1)) :result))
+			       "http://some.where/psis/author/goethe")
+		      (string= (first (getf (second (result q-obj-1)) :result))
+			       "http://some.where/psis/persons/goethe")))
+	      (is (= (length (getf (first (result q-obj-1)) :result)) 1))
+	      (is (string= (first (getf (first (result q-obj-1)) :result))
+			   "http://some.where/psis/poem/erlkoenig"))
+	      (is (string= (getf (first (result q-obj-1)) :variable) "poems"))))
+	(is (= (length (result q-obj-2)) 2))
+	(if (string= (getf (first (result q-obj-2)) :variable) "titles")
+	    (progn
+	      (is (= (length (getf (first (result q-obj-2)) :result)) 4))
+	      (is-true
+	       (find "Mondnacht"
+		     (getf (first (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "Der Erlk?nig"
+		     (getf (first (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "Der Zauberlehrling"
+		     (getf (first (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "Resignation - Eine Phantasie"
+		     (getf (first (result q-obj-2)) :result) :test #'string=))
+	      (string= (getf (second (result q-obj-2)) :variable) "poems")
+	      (is-true
+	       (find "http://some.where/psis/poem/mondnacht"
+		     (getf (second (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "http://some.where/psis/poem/resignation"
+		     (getf (second (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "http://some.where/psis/poem/erlkoenig"
+		     (getf (second (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (or
+		(find "http://some.where/psis/poem/zauberlehrling"
+		      (getf (second (result q-obj-2)) :result) :test #'string=)
+		(find "http://some.where/psis/poem/der_zauberlehrling"
+		      (getf (second (result q-obj-2)) :result) :test #'string=))))
+	    (progn
+	      (is (= (length (getf (second (result q-obj-2)) :result)) 4))
+	      (is-true
+	       (find "Mondnacht"
+		     (getf (second (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "Der Erlk?nig"
+		     (getf (second (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "Der Zauberlehrling"
+		     (getf (second (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "Resignation - Eine Phantasie"
+		     (getf (second (result q-obj-2)) :result) :test #'string=))
+	      (string= (getf (first (result q-obj-2)) :variable) "poems")
+	      (is-true
+	       (find "http://some.where/psis/poem/mondnacht"
+		     (getf (first (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "http://some.where/psis/poem/resignation"
+		     (getf (first (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (find "http://some.where/psis/poem/erlkoenig"
+		     (getf (first (result q-obj-2)) :result) :test #'string=))
+	      (is-true
+	       (or
+		(find "http://some.where/psis/poem/zauberlehrling"
+		      (getf (first (result q-obj-2)) :result) :test #'string=)
+		(find "http://some.where/psis/poem/der_zauberlehrling"
+		      (getf (first (result q-obj-2)) :result) :test #'string=)))))))))
+
+
+
+
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Sat Dec  4 21:05:06 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 04 Dec 2010 16:05:06 -0500
Subject: [isidorus-cvs] r360 - in trunk/src: . TM-SPARQL base-tools json
	rest_interface
Message-ID: <E1POzI2-0001fM-0S@common-lisp.net>

Author: lgiessmann
Date: Sat Dec  4 16:05:05 2010
New Revision: 360

Log:
fixed ticket #87 => added a JSON-handler for SPARQL-requests; fixed a bug in base-tools:trim-whitespace => #\cr is also added as a whitespace character

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/base-tools/base-tools.lisp
   trunk/src/isidorus.asd
   trunk/src/json/json_exporter.lisp
   trunk/src/rest_interface/rest-interface.lisp
   trunk/src/rest_interface/set-up-json-interface.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Sat Dec  4 16:05:05 2010
@@ -759,9 +759,9 @@
     (let ((result-lists (make-result-lists construct)))
       (reduce-results construct result-lists)
       (let* ((response-variables
-	      (if (*-p construct)
-		  (all-variables construct)
-		  (variables construct)))
+	      (reverse (if (*-p construct)
+			   (all-variables construct)
+			   (variables construct))))
 	     (cleaned-results (make-result-lists construct)))
 	(map 'list #'(lambda(response-variable)
 		       (list :variable response-variable

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Sat Dec  4 16:05:05 2010
@@ -76,7 +76,8 @@
 	    (t
 	     (error (make-sparql-parser-condition
 		     trimmed-query-string (original-query construct)
-		     "SELECT, PREFIX or BASE")))))))
+		     (format nil "SELECT, PREFIX or BASE, but found: ~a..."
+			     (subseq trimmed-query-string 0 10)))))))))
 
 
 (defgeneric parse-select (construct query-string)

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Sat Dec  4 16:05:05 2010
@@ -70,19 +70,19 @@
 (defun trim-whitespace-left (value)
   "Uses string-left-trim with a predefined character-list."
   (declare (String value))
-  (string-left-trim '(#\Space #\Tab #\Newline) value))
+  (string-left-trim '(#\Space #\Tab #\Newline #\cr) value))
 
 
 (defun trim-whitespace-right (value)
   "Uses string-right-trim with a predefined character-list."
   (declare (String value))
-  (string-right-trim '(#\Space #\Tab #\Newline) value))
+  (string-right-trim '(#\Space #\Tab #\Newline #\cr) value))
 
 
 (defun trim-whitespace (value)
   "Uses string-trim with a predefined character-list."
   (declare (String value))
-  (string-trim '(#\Space #\Tab #\Newline) value))
+  (string-trim '(#\Space #\Tab #\Newline #\cr) value))
 
 
 (defun string-starts-with (str prefix &key (ignore-case nil))

Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd	(original)
+++ trunk/src/isidorus.asd	Sat Dec  4 16:05:05 2010
@@ -104,6 +104,7 @@
 		       	:depends-on ("model"
 				     "atom"
 				     "xml"
+				     "TM-SPARQL"
 				     "json"
 				     "threading"))
 	       (:module "unit_tests"
@@ -194,7 +195,8 @@
 				     (:file "json_delete_interface"
 					    :depends-on ("json_importer")))
 	                :depends-on ("model"
-				     "xml"))
+				     "xml"
+				     "TM-SPARQL"))
 	       (:module "ajax"
 			:components ((:static-file "isidorus.html")
 				     (:module "javascripts"

Modified: trunk/src/json/json_exporter.lisp
==============================================================================
--- trunk/src/json/json_exporter.lisp	(original)
+++ trunk/src/json/json_exporter.lisp	Sat Dec  4 16:05:05 2010
@@ -8,7 +8,7 @@
 ;;+-----------------------------------------------------------------------------
 
 (defpackage :json-exporter
-  (:use :cl :json :datamodel)
+  (:use :cl :json :datamodel :TM-SPARQL :base-tools)
   (:export :to-json-string
 	   :get-all-topic-psis
 	   :to-json-string-summary
@@ -475,4 +475,25 @@
 			     (to-json-string-summary topic :revision revision) ","))))
 	       (subseq inner-string 0 (- (length inner-string) 1)))))
 	(concatenate 'string "[" json-string "]"))
-      "null"))
\ No newline at end of file
+      "null"))
+
+
+;; =============================================================================
+;; --- json data sparql-results ------------------------------------------------
+;; =============================================================================
+
+(defmethod to-json-string ((construct SPARQL-Query) &key xtm-id revision)
+  "Returns a JSON string that represents the object query result."
+  (declare (Ignorable revision xtm-id))
+  (let ((query-result (result construct)))
+    (if (not query-result)
+	"null"
+	(let ((j-str "{"))
+	  (loop for entry in query-result
+	     do (push-string
+		 (concatenate
+		  'string
+		  (json:encode-json-to-string (getf entry :variable)) ":"
+		  (json:encode-json-to-string (getf entry :result)) ",")
+		 j-str))
+	  (concatenate 'string (subseq j-str 0 (- (length j-str) 1)) "}")))))
\ No newline at end of file

Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp	(original)
+++ trunk/src/rest_interface/rest-interface.lisp	Sat Dec  4 16:05:05 2010
@@ -12,6 +12,8 @@
   (:use :cl :hunchentoot 
 	:cxml
         :constants
+	:exceptions
+	:TM-SPARQL
         :atom 
         :datamodel
         :exporter
@@ -44,7 +46,8 @@
 	   :*ajax-user-interface-file-path*
 	   :*ajax-javascript-directory-path*
 	   :*ajax-javascript-url-prefix*
-	   :*xtm-commit-prefix*))
+	   :*xtm-commit-prefix*
+	   :*sparql-url*))
 
 
 (in-package :rest-interface)

Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp	(original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp	Sat Dec  4 16:05:05 2010
@@ -59,6 +59,8 @@
 (defparameter *mark-as-deleted-url* "/mark-as-deleted")
 ;the get url to request the latest revision of the storage
 (defparameter *latest-revision-url* "/json/latest-revision/?$")
+;the ulr to invoke a SPARQL query
+(defparameter *sparql-url* "/json/tm-sparql/?$")
 
 
 (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*)
@@ -80,7 +82,8 @@
 			      (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*)
 			      (mark-as-deleted-url *mark-as-deleted-url*)
 			      (latest-revision-url *latest-revision-url*)
-			      (xtm-commit-prefix *xtm-commit-prefix*))
+			      (xtm-commit-prefix *xtm-commit-prefix*)
+			      (sparql-url *sparql-url*))
   "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table
    and also registers a file-hanlder to the html-user-interface"
 
@@ -162,6 +165,9 @@
    hunchentoot:*dispatch-table*)
   (push
    (create-regex-dispatcher latest-revision-url #'return-latest-revision)
+   hunchentoot:*dispatch-table*)
+  (push
+   (create-regex-dispatcher sparql-url #'return-tm-sparql)
    hunchentoot:*dispatch-table*))
 
 ;; =============================================================================
@@ -485,6 +491,28 @@
 	(setf (hunchentoot:content-type*) "text")
 	(format nil "Condition: \"~a\"" err)))))
 
+
+(defun return-tm-sparql (&optional param)
+  "Returns a JSON object representing a SPARQL response."
+  (declare (Ignorable param))
+  (handler-case
+      (if (eql (hunchentoot:request-method*) :POST)
+	  (let ((external-format (flexi-streams:make-external-format
+				  :UTF-8 :eol-style :LF)))
+	    (let ((sparql-request (hunchentoot:raw-post-data
+				   :external-format external-format
+				   :force-text t)))
+	      (to-json-string (make-instance 'SPARQL-Query :query sparql-request
+					     :revision 0))))
+	  (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))
+    (condition (err)
+      (progn
+	(setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+)
+	(setf (hunchentoot:content-type*) "text")
+	(if (typep err 'SPARQL-Parser-Error)
+	    (format nil "SPARQL-Parser-Error: \"~a\"" (exceptions::message err))
+	    (format nil "Condition: \"~a\"" err))))))
+
 ;; =============================================================================
 ;; --- some helper functions ---------------------------------------------------
 ;; =============================================================================



From lgiessmann at common-lisp.net  Tue Dec 14 16:01:39 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 14 Dec 2010 11:01:39 -0500
Subject: [isidorus-cvs] r361 - in trunk/src: . TM-SPARQL unit_tests
Message-ID: <E1PSXJr-0001NN-0h@common-lisp.net>

Author: lgiessmann
Date: Tue Dec 14 11:01:38 2010
New Revision: 361

Log:
TM-SPARQL: changed some function in the sparql-parser into mehtods=>SPARQL-Query; created the structure for the filter parser

Added:
   trunk/src/TM-SPARQL/sparql_filter.lisp
Modified:
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/isidorus.asd
   trunk/src/unit_tests/sparql_test.lisp

Added: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- (empty file)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Tue Dec 14 11:01:38 2010
@@ -0,0 +1,45 @@
+;;+-----------------------------------------------------------------------------
+;;+  Isidorus
+;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
+;;+
+;;+  Isidorus is freely distributable under the LLGPL license.
+;;+  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
+;;+  trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+(in-package :TM-SPARQL)
+
+(defun parse-filter (query-string query-object)
+  "A helper functions that returns a filter and the next-query string
+   in the form (:next-query string :filter object)."
+  (declare (String query-string)
+	   (SPARQL-Query query-object))
+  ;;TODO: implement
+  ;; *replace () by (progn )
+  ;; *replace ', """, ''' by "
+  ;; *replace !x by (not x)
+  ;; *replace +x by (1+ x)
+  ;; *replace -x by (1- x)
+  ;; *replace x operator y by (filter-operator x y)
+  ;;   *=, !=, <, >, <=, >=, +, -, *, /, ||, &&
+  ;; *replace function(x), function(x, y), function(x, y, z)
+  ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
+  ;; *create and store this filter object
+  )
+
+(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 (length delimiter)))
+	nil)))
\ No newline at end of file

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Tue Dec 14 11:01:38 2010
@@ -70,7 +70,7 @@
 	     (parse-base construct (string-after trimmed-query-string "BASE")
 			 #'parser-start))
 	    ((= (length trimmed-query-string) 0)
-	     ;; If there is only a BASE and/or PREFIX statement return an
+	     ;; If there is only a BASE and/or PREFIX statement return a
 	     ;; query-object with the result nil
 	     construct)
 	    (t
@@ -128,7 +128,7 @@
 		     trimmed-str (original-query construct)
 		     "FILTER, BASE, or triple. Grouping is currently no implemented.")))
 	    ((string-starts-with trimmed-str "FILTER")
-	     nil) ;TODO: parse-filter and store it in construct => extend class
+	     (parse-filter (string-after trimmed-str "FILTER") construct))
 	    ((string-starts-with trimmed-str "OPTIONAL")
 	     (error (make-sparql-parser-condition
 		     trimmed-str (original-query construct)
@@ -144,100 +144,89 @@
 	     (parse-triple construct trimmed-str :last-subject last-subject))))))
 
 
-(defun parse-filter (query-string query-object)
-  "A helper functions that returns a filter and the next-query string
-   in the form (:next-query string :filter object)."
-  ;; !, +, -, *, /, (, ), &&, ||, =, !=, <, >, >=, <=, REGEX(string, pattern)
-  (declare (String query-string)
-	   (SPARQL-Query query-object))
-  ;;TODO: implement
-  )
-
-
-(defun parse-triple-elem (query-string query-object &key (literal-allowed nil))
-  "A helper function to parse a subject or predicate of an RDF triple."
-  (declare (String query-string)
-	   (SPARQL-Query query-object)
-	   (Boolean literal-allowed))
-  (let ((trimmed-str (cut-comment query-string)))
-    (cond ((string-starts-with trimmed-str "a ") ;;rdf:type
-	   (list :next-query (cut-comment (subseq trimmed-str 1))
-		 :value (make-instance 'SPARQL-Triple-Elem
-				       :elem-type 'IRI
-				       :value *type-psi*)))
-	  ((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
-				       :additional-delimiters (list "}"))))
-	     (list :next-query (cut-comment (getf result :next-query))
+(defgeneric parse-triple-elem (construct query-string &key literal-allowed)
+  (:documentation "A helper function to parse a subject or predicate of an RDF triple.")
+  (:method ((construct SPARQL-Query) (query-string String)
+	    &key (literal-allowed nil))
+    (declare (Boolean literal-allowed))
+    (let ((trimmed-str (cut-comment query-string)))
+      (cond ((string-starts-with trimmed-str "a ") ;;rdf:type
+	     (list :next-query (cut-comment (subseq trimmed-str 1))
 		   :value (make-instance 'SPARQL-Triple-Elem
-					 :elem-type 'VARIABLE
-					 :value (getf result :value)))))
-	  (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 "\"")
+					 :elem-type 'IRI
+					 :value *type-psi*)))
+	    ((string-starts-with trimmed-str "<")
+	     (parse-base-suffix-pair construct trimmed-str))
+	    ((or (string-starts-with trimmed-str "?")
+		 (string-starts-with trimmed-str "$"))
+	     (let ((result
+		    (parse-variable-name construct trimmed-str
+					 :additional-delimiters (list "}"))))
+	       (list :next-query (cut-comment (getf result :next-query))
+		     :value (make-instance 'SPARQL-Triple-Elem
+					   :elem-type 'VARIABLE
+					   :value (getf result :value)))))
+	    (t
+	     (if (or (string-starts-with-digit trimmed-str)
+		     (string-starts-with trimmed-str "\"")
+		     (string-starts-with trimmed-str "true")
+		     (string-starts-with trimmed-str "false")
 		     (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 (make-instance
-		  'SPARQL-Triple-Elem
-		  :elem-type 'LITERAL
-		  :value (getf value-type-lang-query :value)
-		  :literal-lang (getf value-type-lang-query :lang)
-		  :literal-datatype (getf value-type-lang-query :type)))))
-
-
-(defun parse-literal-string-value (query-string query-object)
-  "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 (if (getf result-2 :type)
-		     (getf result-2 :type)
-		     *xml-string*))
-	 (l-lang (getf result-2 :lang))
-	 (next-query (getf result-2 :next-query)))
-    (list :next-query next-query :lang l-lang :type l-type
-	  :value (cast-literal l-value l-type))))
+		 (progn
+		   (unless literal-allowed
+		     (error (make-sparql-parser-condition
+			     trimmed-str (original-query construct)
+			     "an IRI of the form prefix:suffix or <iri> but found a literal.")))
+		   (parse-literal-elem construct trimmed-str))
+		 (parse-prefix-suffix-pair construct trimmed-str)))))))
+
+
+(defgeneric parse-literal-elem (construct query-string)
+  (:documentation "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).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (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 construct trimmed-str))
+		  ((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 construct trimmed-str)))))
+      (list :next-query (getf value-type-lang-query :next-query)
+	    :value (make-instance
+		    'SPARQL-Triple-Elem
+		    :elem-type 'LITERAL
+		    :value (getf value-type-lang-query :value)
+		    :literal-lang (getf value-type-lang-query :lang)
+		    :literal-datatype (getf value-type-lang-query :type))))))
+  
+  
+(defgeneric parse-literal-string-value (construct query-string)
+  (:documentation "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).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (result-1 (separate-literal-value construct trimmed-str))
+	   (after-literal-value (getf result-1 :next-query))
+	   (l-value (getf result-1 :literal))
+	   (result-2 (separate-literal-lang-or-type
+		      construct after-literal-value))
+	   (l-type (if (getf result-2 :type)
+		       (getf result-2 :type)
+		       *xml-string*))
+	   (l-lang (getf result-2 :lang))
+	   (next-query (getf result-2 :next-query)))
+      (list :next-query next-query :lang l-lang :type l-type
+	    :value (cast-literal l-value l-type)))))
 
 
 (defun cast-literal (literal-value literal-type)
@@ -278,171 +267,150 @@
 	     (write-to-string literal-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-1 (list "." ";" "}" " " (string #\tab)
-			    (string #\newline)))
-	(delimiters-2 (list " ." ". " ";" "}" " " (string #\tab)
-			    (string #\newline)
-			    (concatenate 'string "." (string #\newline))
-			    (concatenate 'string "." (string #\tab)))))
-    (cond ((string-starts-with query-string "@")
-	   (let ((end-pos (search-first delimiters-1
-					(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-2 (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 (cut-comment next-query)
-		     :type final-type :lang nil))))
-	  (t
-	   (list :next-query (cut-comment 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 (length delimiter)))
-	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 :next-query string."
-  (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)
+(defgeneric separate-literal-lang-or-type (construct query-string)
+  (:documentation "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.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((delimiters-1 (list "." ";" "}" " " (string #\tab)
+			      (string #\newline)))
+	  (delimiters-2 (list " ." ". " ";" "}" " " (string #\tab)
+			      (string #\newline)
+			      (concatenate 'string "." (string #\newline))
+			      (concatenate 'string "." (string #\tab)))))
+      (cond ((string-starts-with query-string "@")
+	     (let ((end-pos (search-first delimiters-1
+					  (subseq query-string 1))))
+	       (unless end-pos
+		 (error (make-sparql-parser-condition
+			 query-string (original-query construct)
+			 "'.', ';', '}', ' ', '\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-2 (subseq query-string 2))))
+	       (unless end-pos
+		 (error (make-sparql-parser-condition
+			 query-string (original-query construct)
+			 "'. ', ,' .', ';', '}', ' ', '\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 construct type-str)
+				      (get-prefix construct type-str)
+				      type-str)))
+		 (list :next-query (cut-comment next-query)
+		       :type final-type :lang nil))))
+	    (t
+	     (list :next-query (cut-comment query-string) :type nil :lang nil))))))
+
+
+(defgeneric separate-literal-value (construct query-string)
+  (:documentation "A helper function that returns (:next-query string
+                   :literal string). The literal string contains the
+                   pure literal value.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (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 construct)
+				     "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)))))
+
+
+(defgeneric parse-literal-number-value (construct query-string)
+  (:documentation "A helper function that parses any number that is a literal.
+                   The return value is of the form
+                  (list :value nil :type string :next-query string.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (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)
-		"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))))
-	 (next-query (getf result :next-query)))
-    (list :next-query (cut-comment next-query)
-	  :value (make-instance 'SPARQL-Triple-Elem
-				:elem-type 'IRI
-				:value result-uri))))
-
-
-(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 ":")))
-	 (full-url
-	  (when (and suffix prefix)
-	    (get-prefix query-object (concatenate 'string prefix ":" suffix)))))
-    (unless (and end-pos prefix suffix)
-      (error (make-sparql-parser-condition
-	      trimmed-str (original-query query-object)
-	      "An IRI of the form prefix:suffix")))
-    (unless full-url
-      (error (make-condition
-	      'sparql-parser-error
-	      :message (format nil "The prefix in \"~a:~a\" is not registered"
-			       prefix suffix))))
-    (list :next-query (cut-comment
-		       (string-after
-			trimmed-str
-			(concatenate 'string prefix ":" suffix)))
-	  :value (make-instance 'SPARQL-Triple-Elem
-				:elem-type 'IRI
-				:value full-url))))
+		trimmed-str (original-query construct)
+		"'. ', , ';' ' ', '\\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 construct)
+		  "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))))))
+
+
+(defgeneric parse-base-suffix-pair (construct query-string)
+  (:documentation "A helper function that returns a list of the form
+                  (list :next-query string :value (:value uri :type 'IRI)).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (result (parse-closed-value trimmed-str construct))
+	   (result-uri
+	    (if (or (absolute-uri-p (getf result :value))
+		    (not (base-value construct)))
+		(getf result :value)
+		(concatenate-uri (base-value construct)
+				 (getf result :value))))
+	   (next-query (getf result :next-query)))
+      (list :next-query (cut-comment next-query)
+	    :value (make-instance 'SPARQL-Triple-Elem
+				  :elem-type 'IRI
+				  :value result-uri)))))
+
+
+(defgeneric parse-prefix-suffix-pair(construct query-string)
+  (:documentation "A helper function that returns a list of the form
+                  (list :next-query string :value (:value uri :type 'IRI)).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (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 ":")))
+	   (full-url
+	    (when (and suffix prefix)
+	      (get-prefix construct (concatenate 'string prefix ":" suffix)))))
+      (unless (and end-pos prefix suffix)
+	(error (make-sparql-parser-condition
+		trimmed-str (original-query construct)
+		"An IRI of the form prefix:suffix")))
+      (unless full-url
+	(error (make-condition
+		'sparql-parser-error
+		:message (format nil "The prefix in \"~a:~a\" is not registered"
+				 prefix suffix))))
+      (list :next-query (cut-comment
+			 (string-after
+			  trimmed-str
+			  (concatenate 'string prefix ":" suffix)))
+	    :value (make-instance 'SPARQL-Triple-Elem
+				  :elem-type 'IRI
+				  :value full-url)))))
 
 
 (defgeneric parse-triple (construct query-string &key last-subject)
@@ -452,14 +420,15 @@
     (let* ((trimmed-str (cut-comment query-string))
 	   (subject-result (if last-subject ;;is used after a ";"
 			       last-subject
-			       (parse-triple-elem trimmed-str construct)))
+			       (parse-triple-elem construct trimmed-str)))
 	   (predicate-result (parse-triple-elem
+			      construct
 			      (if last-subject
 				  trimmed-str
-				  (getf subject-result :next-query))
-			      construct))
-	   (object-result (parse-triple-elem (getf predicate-result :next-query)
-					     construct :literal-allowed t)))
+				  (getf subject-result :next-query))))
+	   (object-result (parse-triple-elem construct
+					     (getf predicate-result :next-query)
+					     :literal-allowed t)))
       (add-triple construct
 		  (make-instance 'SPARQL-Triple
 				 :subject (if last-subject
@@ -487,42 +456,42 @@
 	  (if (string-starts-with trimmed-str "*")
 	      (progn (add-variable construct "*")
 		     (parse-variables construct (string-after trimmed-str "*")))
-	      (let ((result (parse-variable-name trimmed-str construct)))
+	      (let ((result (parse-variable-name construct trimmed-str)))
 		(add-variable construct (getf result :value))
 		(parse-variables construct (getf result :next-query))))))))
 
 
-(defun parse-variable-name (query-string query-object &key additional-delimiters)
-  "A helper function that parses the first non-whitespace character
-   in the query. since it must be a variable, it must be prefixed
-   by a ? or $. The return value is of the form
-   (:next-query string :value string)."
-  (declare (String query-string)
-	   (SPARQL-Query query-object)
-	   (List additional-delimiters))
-  (let ((trimmed-str (cut-comment query-string))
-	(delimiters (append
-		     (list " " "?" "$" "." (string #\newline) (string #\tab))
-		     additional-delimiters)))
-    (unless (or (string-starts-with trimmed-str "?")
-		(string-starts-with trimmed-str "$"))
-      (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"))))
-	   (next-query (string-after trimmed-str var-name))
-	   (normalized-var-name 
-	    (if (<= (length var-name) 1)
-		(error (make-sparql-parser-condition
-			next-query (original-query query-object)
-			"a variable name"))
-		(subseq var-name 1))))
-      (list :next-query next-query :value normalized-var-name))))
+(defgeneric parse-variable-name (construct query-string &key additional-delimiters)
+  (:documentation "A helper function that parses the first non-whitespace character
+                   in the query. since it must be a variable, it must be prefixed
+                   by a ? or $. The return value is of the form
+                  (:next-query string :value string).")
+  (:method ((construct SPARQL-Query) (query-string String)
+	    &key (additional-delimiters))
+    (declare (List additional-delimiters))
+    (let ((trimmed-str (cut-comment query-string))
+	  (delimiters (append
+		       (list " " "?" "$" "." (string #\newline) (string #\tab))
+		       additional-delimiters)))
+      (unless (or (string-starts-with trimmed-str "?")
+		  (string-starts-with trimmed-str "$"))
+	(error (make-sparql-parser-condition
+		trimmed-str (original-query construct) "? 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 construct)
+			  "space, newline, tab, ?, ., $ or WHERE"))))
+	     (next-query (string-after trimmed-str var-name))
+	     (normalized-var-name 
+	      (if (<= (length var-name) 1)
+		  (error (make-sparql-parser-condition
+			  next-query (original-query construct)
+			  "a variable name"))
+		  (subseq var-name 1))))
+	(list :next-query next-query :value normalized-var-name)))))
 
 
 (defgeneric parse-base (construct query-string next-fun)

Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd	(original)
+++ trunk/src/isidorus.asd	Tue Dec 14 11:01:38 2010
@@ -42,8 +42,10 @@
 			:depends-on ("constants" "base-tools"))
 	       (:module "TM-SPARQL"
 			:components ((:file "sparql")
+				     (:file "sparql_filter"
+					    :depends-on ("sparql"))
 				     (:file "sparql_parser"
-					    :depends-on ("sparql")))
+					    :depends-on ("sparql" "sparql_filter")))
 			:depends-on ("constants" "base-tools" "model"))
 	       (:module "xml"
 			:components ((:module "xtm"

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Dec 14 11:01:38 2010
@@ -169,7 +169,7 @@
 	(query-9 (concatenate 'string "\"13e4\"^^" *xml-boolean* " ."))
 	(dummy-object (make-instance 'SPARQL-Query :query "")))
     (is-true dummy-object)
-    (let ((res (tm-sparql::parse-literal-elem query-1 dummy-object)))
+    (let ((res (tm-sparql::parse-literal-elem dummy-object query-1)))
       (is (string= (getf res :next-query) "."))
       (is (string= (tm-sparql::value (getf res :value))
 		   "literal-value"))
@@ -178,35 +178,35 @@
       (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-string*))
       (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
-    (let ((res (tm-sparql::parse-literal-elem query-2 dummy-object)))
+    (let ((res (tm-sparql::parse-literal-elem dummy-object query-2)))
       (is (string= (getf res :next-query) "."))
       (is (eql (tm-sparql::value (getf res :value)) t))
       (is-false (tm-sparql::literal-lang (getf res :value)))
       (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-boolean*))
       (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
-    (let ((res (tm-sparql::parse-literal-elem query-3 dummy-object)))
+    (let ((res (tm-sparql::parse-literal-elem dummy-object query-3)))
       (is (string= (getf res :next-query) "}"))
       (is (eql (tm-sparql::value (getf res :value)) nil))
       (is-false (tm-sparql::literal-lang (getf res :value)))
       (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-boolean*))
       (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
-    (let ((res (tm-sparql::parse-literal-elem query-4 dummy-object)))
+    (let ((res (tm-sparql::parse-literal-elem dummy-object query-4)))
       (is (string= (getf res :next-query) (string #\tab)))
       (is (= (tm-sparql::value (getf res :value)) 1234.43e10))
       (is-false (tm-sparql::literal-lang (getf res :value)))
       (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-double*))
       (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
-    (let ((res (tm-sparql::parse-literal-elem query-5 dummy-object)))
+    (let ((res (tm-sparql::parse-literal-elem dummy-object query-5)))
       (is (string= (getf res :next-query) ";"))
       (is (eql (tm-sparql::value (getf res :value)) t))
       (is-false (tm-sparql::literal-lang (getf res :value)))
       (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-boolean*))
       (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
-    (let ((res (tm-sparql::parse-literal-elem query-6 dummy-object)))
+    (let ((res (tm-sparql::parse-literal-elem dummy-object query-6)))
       (is (string= (getf res :next-query)
 		   (concatenate 'string "." (string #\newline))))
       (is (eql (tm-sparql::value (getf res :value)) 123.4))
@@ -214,7 +214,7 @@
       (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-double*))
       (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
-    (let ((res (tm-sparql::parse-literal-elem query-7 dummy-object)))
+    (let ((res (tm-sparql::parse-literal-elem dummy-object query-7)))
       (is (string= (getf res :next-query) "."))
       (is (string= (tm-sparql::value (getf res :value))
 		   "Just a test
@@ -225,9 +225,9 @@
 		   *xml-string*))
       (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL)))
     (signals sparql-parser-error
-      (tm-sparql::parse-literal-elem query-8 dummy-object))
+      (tm-sparql::parse-literal-elem dummy-object query-8))
     (signals sparql-parser-error
-      (tm-sparql::parse-literal-elem query-9 dummy-object))))
+      (tm-sparql::parse-literal-elem dummy-object query-9))))
 
 
 (test test-parse-triple-elem
@@ -245,40 +245,40 @@
 	(var 'TM-SPARQL::VARIABLE)
 	(iri 'TM-SPARQL::IRI))
     (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value")
-    (let ((res (tm-sparql::parse-triple-elem query-1 dummy-object)))
+    (let ((res (tm-sparql::parse-triple-elem dummy-object query-1)))
       (is (string= (getf res :next-query) "."))
       (is (string= (tm-sparql::value (getf res :value)) "var1"))
       (is (eql (tm-sparql::elem-type (getf res :value)) var)))
-    (let ((res (tm-sparql::parse-triple-elem query-2 dummy-object)))
+    (let ((res (tm-sparql::parse-triple-elem dummy-object query-2)))
       (is (string= (getf res :next-query) ";"))
       (is (string= (tm-sparql::value (getf res :value)) "var2"))
       (is (eql (tm-sparql::elem-type (getf res :value)) var)))
-    (let ((res (tm-sparql::parse-triple-elem query-3 dummy-object)))
+    (let ((res (tm-sparql::parse-triple-elem dummy-object query-3)))
       (is (string= (getf res :next-query) "}"))
       (is (string= (tm-sparql::value (getf res :value)) "var3"))
       (is (eql (tm-sparql::elem-type (getf res :value)) var)))
-    (let ((res (tm-sparql::parse-triple-elem query-4 dummy-object)))
+    (let ((res (tm-sparql::parse-triple-elem dummy-object query-4)))
       (is (string= (getf res :next-query) "."))
       (is (string= (tm-sparql::value (getf res :value))
 		   "http://full.url"))
       (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
-    (let ((res (tm-sparql::parse-triple-elem query-5 dummy-object)))
+    (let ((res (tm-sparql::parse-triple-elem dummy-object query-5)))
       (is (string= (getf res :next-query) "}"))
       (is (string= (tm-sparql::value (getf res :value))
 		   "http://base.value/url-suffix"))
       (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
-    (let ((res (tm-sparql::parse-triple-elem query-6 dummy-object)))
+    (let ((res (tm-sparql::parse-triple-elem dummy-object query-6)))
       (is (string= (getf res :next-query) "."))
       (is (string= (tm-sparql::value (getf res :value))
 		   "http://prefix.value/suffix"))
       (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
-    (let ((res (tm-sparql::parse-triple-elem query-7 dummy-object)))
+    (let ((res (tm-sparql::parse-triple-elem dummy-object query-7)))
       (is (string= (getf res :next-query) "}"))
       (is (string= (tm-sparql::value (getf res :value))
 		   "http://prefix.value/suffix"))
       (is (eql (tm-sparql::elem-type (getf res :value)) iri)))
     (signals sparql-parser-error 
-      (tm-sparql::parse-triple-elem query-8 dummy-object))))
+      (tm-sparql::parse-triple-elem dummy-object query-8))))
 
 
 (test test-parse-group-1



From lgiessmann at common-lisp.net  Tue Dec 14 21:07:50 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 14 Dec 2010 16:07:50 -0500
Subject: [isidorus-cvs] r362 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1PSc6A-0005BH-8w@common-lisp.net>

Author: lgiessmann
Date: Tue Dec 14 16:07:50 2010
New Revision: 362

Log:
TM-SPARQL: added some functions that separate a single filter-statement, handle bracketing, and handle unsupported functions

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/base-tools/base-tools.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Tue Dec 14 16:07:50 2010
@@ -9,14 +9,42 @@
 
 (in-package :TM-SPARQL)
 
-(defun parse-filter (query-string query-object)
-  "A helper functions that returns a filter and the next-query string
-   in the form (:next-query string :filter object)."
-  (declare (String query-string)
-	   (SPARQL-Query query-object))
+
+(defparameter *supported-functions*
+  (list "BOUND" "isLITERAL" "STR" "DATATYPE" "REGEX")
+  "Contains all supported SPARQL-functions")
+
+
+(defparameter *supported-operators*
+  (list "!" "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/")
+  "Contains all supported operators, note some unary operators
+   are handled as functions, e.g. + and -")
+
+
+(defun make-sparql-parser-condition(rest-of-query entire-query expected)
+  "Creates a spqrql-parser-error object."
+  (declare (String rest-of-query entire-query expected))
+  (let ((message
+	 (format nil "The query:~%\"~a\"~%~%has a bad token at position ~a => ~a.~%Expected: ~a"
+		 entire-query (- (length entire-query)
+				 (length rest-of-query))
+		 (subseq entire-query (- (length entire-query)
+					 (length rest-of-query)))
+		 expected)))
+    (make-condition 'sparql-parser-error :message message)))
+
+
+(defgeneric parse-filter (construct query-string)
+  (:documentation "A helper functions that returns a filter and the next-query
+                   string in the form (:next-query string :filter object).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((result-set-boundings (set-boundings construct query-string))
+	   (filter-string (getf result-set-boundings :filter-string))
+	   (next-query (getf result-set-boundings :next-query))
+	   ))))
   ;;TODO: implement
-  ;; *replace () by (progn )
-  ;; *replace ', """, ''' by "
+  ;; **replace () by (progn )
+  ;; **replace ', """, ''' by '''
   ;; *replace !x by (not x)
   ;; *replace +x by (1+ x)
   ;; *replace -x by (1- x)
@@ -25,7 +53,147 @@
   ;; *replace function(x), function(x, y), function(x, y, z)
   ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
   ;; *create and store this filter object
-  )
+
+
+(defgeneric set-boundings (construct query-string)
+  (:documentation "Returns a list of the form (:next-query <string>
+                   :filter-string <string>). next-query is a string containing
+                   the query after the filter and filter is a string
+                   containing the actual filter. Additionally all free
+                   '(' are transformed into '(progn' and all ', ''', \"\"\"
+                   are transformed into \".")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((filter-string "")
+	  (open-brackets 0)
+	  (result nil))
+      (dotimes (idx (length query-string))
+	(let ((current-char (subseq query-string idx (1+ idx))))
+	  (cond ((string= "(" current-char)
+		 (setf open-brackets (1+ open-brackets))
+		 (if (progn-p query-string idx)
+		     (push-string "(progn " filter-string)
+		     (push-string current-char filter-string)))
+		((string= ")" current-char)
+		 (setf open-brackets (1- open-brackets))
+		 (when (< open-brackets 0)
+		   (make-sparql-parser-condition
+		    (subseq query-string idx)
+		    (original-query construct)
+		    "an opening bracket \"(\" is missing for the current closing one"))
+		 (push-string current-char filter-string))
+		((or (string= "'" current-char)
+		     (string= "\"" current-char))
+		 (let ((result (get-literal (subseq query-string idx))))
+		   (unless result
+		     (make-sparql-parser-condition
+		      (subseq query-string idx)
+		      (original-query construct)
+		      "a closing character for the given literal"))
+		   (setf idx (- (1- (length query-string))
+				(length (getf result :next-query))))
+		   (push-string (getf result :literal) filter-string)))
+		((string= "#" current-char)
+		 (let ((comment-string
+			(string-until (subseq query-string idx)
+				      (string #\newline))))
+		   (setf idx (+ idx (length comment-string)))))
+		((and (string= current-char (string #\newline))
+		      (= 0 open-brackets))
+		 (setf result
+		       (list :next-query (subseq query-string idx)
+			     :filter-string filter-string))
+		 (setf idx (1- (length query-string))))
+		((string= current-char "}")
+		 (when (/= open-brackets 0)
+		   (make-sparql-parser-condition
+		    (subseq query-string idx)
+		    (original-query construct)
+		    "a valid filter, but the filter is not complete"))
+		 (setf result
+		       (list :next-query (subseq query-string idx)
+			     :filter-string filter-string)))
+		(t
+		 (push-string current-char filter-string)))))
+      result)))
+
+
+(defun progn-p(query-string idx)
+  "Returns t if the ( at position idx in the filter string
+  represents a (progn) block."
+  (declare (String query-string)
+	   (Integer idx))
+  (let* ((delimiters (append (list " " (string #\Space) (string #\Tab)
+				   (string #\Newline) (string #\cr) "(" ")")
+			     *supported-operators*))
+	 (string-before (trim-whitespace-right (subseq query-string 0 idx)))
+	 (fragment-before-idx
+	  (search-first delimiters string-before :from-end t))
+	 (fragment-before
+	  (if (and (not fragment-before-idx)
+		   (and (> (length string-before) 0)
+			(not (find string-before *supported-functions*
+				   :test #'string=))))
+	      (error (make-condition
+		      'SPARQL-PARSER-ERROR
+		      :message (format nil "Invalid filter: \"~a\"~%"
+				       query-string)))
+	      (when fragment-before-idx
+		(let ((inner-value
+		       (subseq string-before fragment-before-idx)))
+		  (if (and (> (length inner-value) 1)
+			   (string-starts-with inner-value "("))
+		      (subseq inner-value 1)
+		      inner-value))))))
+    (if fragment-before
+	(progn
+	  (when (or (string-starts-with fragment-before "?")
+		    (string-starts-with fragment-before "$"))
+	    (error
+	     (make-condition
+	      'SPARQL-PARSER-ERROR
+	      :message (format nil "Invalid filter: found \"~a\" but expected ~a"
+			       fragment-before *supported-functions*))))
+	  (when (not (find fragment-before (append *supported-functions*
+						   delimiters)
+			   :test #'string=))
+	    (error
+	     (make-condition
+	      'SPARQL-PARSER-ERROR
+	      :message
+	      (format nil "Invalid character: ~a, expected characters: ~a"
+		      fragment-before (append *supported-functions* delimiters)))))
+	  (if (find fragment-before *supported-functions* :test #'string=)
+	      nil
+	      t))
+	(if (find string-before *supported-functions* :test #'string=)
+	    nil
+	    t))))
+
+
+(defun get-literal (query-string)
+  "Returns a list of the form (:next-query <string> :literal <string>
+   where next-query is the query after the found literal and literal
+   is the literal string."
+  (declare (String query-string))
+  (cond ((or (string-starts-with query-string "\"\"\"")
+	     (string-starts-with query-string "'''"))
+	 (let ((literal-end
+		(find-literal-end (subseq query-string 3) (subseq query-string 0 3))))
+	   (when literal-end
+	     (list :next-query (subseq query-string (+ 3 literal-end))
+		   :literal (concatenate 'string "'''"
+					 (subseq query-string 3 literal-end)
+					 "'''")))))
+	((or (string-starts-with query-string "\"")
+	     (string-starts-with query-string "'"))
+	 (let ((literal-end
+		(find-literal-end (subseq query-string 1)(subseq query-string 0 1))))
+	   (when literal-end
+	     (list :next-query (subseq query-string (+ 1 literal-end))
+		   :literal (concatenate 'string "'''"
+					 (subseq query-string 1 literal-end)
+					 "'''")))))))
+
 
 (defun find-literal-end (query-string delimiter &optional (overall-pos 0))
   "Returns the end of the literal corresponding to the passed delimiter

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Tue Dec 14 16:07:50 2010
@@ -9,19 +9,6 @@
 
 (in-package :TM-SPARQL)
 
-(defun make-sparql-parser-condition(rest-of-query entire-query expected)
-  "Creates a spqrql-parser-error object."
-  (declare (String rest-of-query entire-query expected))
-  (let ((message
-	 (format nil "The query:~%\"~a\"~%~%has a bad token at position ~a => ~a.~%Expected: ~a"
-		 entire-query (- (length entire-query)
-				 (length rest-of-query))
-		 (subseq entire-query (- (length entire-query)
-					 (length rest-of-query)))
-		 expected)))
-    (make-condition 'sparql-parser-error :message message)))
-
-
 (defun parse-closed-value(query-string query-object &key (open "<") (close ">"))
   "A helper function that checks the value of a statement within
    two brackets, i.e. <prefix-value>. A list of the

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Tue Dec 14 16:07:50 2010
@@ -150,16 +150,20 @@
 	nil)))
 
 
-(defun search-first (search-strings main-string)
+(defun search-first (search-strings main-string &key from-end)
   "Returns the position of one of the search-strings. The returned position
    is the one closest to 0. If no search-string is found, nil is returned."
   (declare (String main-string)
-	   (List search-strings))
+	   (List search-strings)
+	   (Boolean from-end))
   (let ((positions
-	 (remove-null (map 'list #'(lambda(search-str)
-				     (search search-str main-string))
-			   search-strings))))
-    (let ((sorted-positions (sort positions #'<)))
+	 (remove-null
+	  (map 'list #'(lambda(search-str)
+			 (search search-str main-string :from-end from-end))
+	       search-strings))))
+    (let ((sorted-positions (if from-end
+				(sort positions #'>)
+				(sort positions #'<))))
       (when sorted-positions
 	(first sorted-positions)))))
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Dec 14 16:07:50 2010
@@ -29,7 +29,8 @@
 	   :test-set-result-3
 	   :test-set-result-4
 	   :test-set-result-5
-	   :test-result))
+	   :test-result
+	   :test-set-boundings))
 
 
 (in-package :sparql-test)
@@ -1038,6 +1039,29 @@
 		      (getf (first (result q-obj-2)) :result) :test #'string=)))))))))
 
 
+(test test-set-boundings
+  "Tests various cases of the function set-boundings"
+  (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
+	 (str-1 "BOUND((  (?var)  )) || (isLITERAL($var) && ?var = 'abc')}")
+	 (result-1 (tm-sparql::set-boundings dummy-object str-1))
+	 (str-2
+	  "(REGEX(?var1, '''''', ?var3) || (?var1 > ?var3 && (STR( ?var) = \"abc\")))}")
+	 (result-2 (tm-sparql::set-boundings dummy-object str-2))
+	 (str-3
+	  "DATATYPE(?var3) || +?var1 = -?var2
+           ?var1 ?var2 ?var3}")
+	 (result-3 (tm-sparql::set-boundings dummy-object str-3)))
+    (is-true result-1)
+    (is-true result-2)
+    (is (string= (getf result-1 :filter-string)
+		 "BOUND((progn   (progn ?var)  )) || (progn isLITERAL($var) && ?var = '''abc''')"))
+    (is (string= (getf result-1 :next-query) "}"))
+    (is (string= (getf result-2 :filter-string)
+		 "(progn REGEX(?var1, '''''', ?var3) || (progn ?var1 > ?var3 && (progn STR( ?var) = '''abc''')))"))
+    (is (string= (getf result-2 :next-query) "}"))
+    (is (string= (getf result-3 :filter-string)
+		 "DATATYPE(?var3) || +?var1 = -?var2"))
+    (is (string= (getf result-3 :next-query) (subseq str-3 34)))))
 
 
 (defun run-sparql-tests ()



From lgiessmann at common-lisp.net  Wed Dec 15 09:51:02 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 15 Dec 2010 04:51:02 -0500
Subject: [isidorus-cvs] r363 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1PSo0k-0000WX-9c@common-lisp.net>

Author: lgiessmann
Date: Wed Dec 15 04:51:01 2010
New Revision: 363

Log:
TM-SPARQL: added some unit-tests for the processing of brackets in FILTER-statements => fixed a bug when a function is behind a supported operator without white space

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Wed Dec 15 04:51:01 2010
@@ -20,6 +20,10 @@
   "Contains all supported operators, note some unary operators
    are handled as functions, e.g. + and -")
 
+(defparameter *supported-brackets*
+  (list "(" ")")
+  "Contains all supported brackets in a list of strings.")
+
 
 (defun make-sparql-parser-condition(rest-of-query entire-query expected)
   "Creates a spqrql-parser-error object."
@@ -137,13 +141,16 @@
 		      'SPARQL-PARSER-ERROR
 		      :message (format nil "Invalid filter: \"~a\"~%"
 				       query-string)))
-	      (when fragment-before-idx
-		(let ((inner-value
-		       (subseq string-before fragment-before-idx)))
-		  (if (and (> (length inner-value) 1)
-			   (string-starts-with inner-value "("))
-		      (subseq inner-value 1)
-		      inner-value))))))
+	      (if fragment-before-idx
+		  (subseq string-before fragment-before-idx)
+		  nil))))
+    (when fragment-before
+      (mapcan #'(lambda(operator)
+		  (when (and (string-starts-with fragment-before operator)
+			     (> (length fragment-before) (length operator)))
+		    (setf fragment-before
+			  (string-after fragment-before operator))))
+	      (append *supported-operators* *supported-brackets*)))
     (if fragment-before
 	(progn
 	  (when (or (string-starts-with fragment-before "?")
@@ -160,7 +167,7 @@
 	     (make-condition
 	      'SPARQL-PARSER-ERROR
 	      :message
-	      (format nil "Invalid character: ~a, expected characters: ~a"
+	      (format nil "Invalid character: \"~a\", expected characters: ~a"
 		      fragment-before (append *supported-functions* delimiters)))))
 	  (if (find fragment-before *supported-functions* :test #'string=)
 	      nil

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Dec 15 04:51:01 2010
@@ -1050,7 +1050,11 @@
 	 (str-3
 	  "DATATYPE(?var3) || +?var1 = -?var2
            ?var1 ?var2 ?var3}")
-	 (result-3 (tm-sparql::set-boundings dummy-object str-3)))
+	 (result-3 (tm-sparql::set-boundings dummy-object str-3))
+	 (str-4 "DATATYPE(?var3) ||isLITERAL(+?var1 = -?var2)}")
+	 (result-4 (tm-sparql::set-boundings dummy-object str-4))
+	 (str-5 "DATATYPE(?var3) ||(isLITERAL  (+?var1 = -?var2))}")
+	 (result-5 (tm-sparql::set-boundings dummy-object str-5)))
     (is-true result-1)
     (is-true result-2)
     (is (string= (getf result-1 :filter-string)
@@ -1061,8 +1065,13 @@
     (is (string= (getf result-2 :next-query) "}"))
     (is (string= (getf result-3 :filter-string)
 		 "DATATYPE(?var3) || +?var1 = -?var2"))
-    (is (string= (getf result-3 :next-query) (subseq str-3 34)))))
-
+    (is (string= (getf result-3 :next-query) (subseq str-3 34)))
+    (is (string= (getf result-4 :filter-string)
+		 "DATATYPE(?var3) ||isLITERAL(+?var1 = -?var2)"))
+    (is (string= (getf result-4 :next-query) "}"))
+    (is (string= (getf result-5 :filter-string)
+		 "DATATYPE(?var3) ||(progn isLITERAL  (+?var1 = -?var2))"))
+    (is (string= (getf result-5 :next-query) "}"))))
 
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Wed Dec 15 13:15:40 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 15 Dec 2010 08:15:40 -0500
Subject: [isidorus-cvs] r364 - in trunk/src: TM-SPARQL base-tools
Message-ID: <E1PSrCm-000761-EA@common-lisp.net>

Author: lgiessmann
Date: Wed Dec 15 08:15:40 2010
New Revision: 364

Log:
TM-SPARQL: added the evaluation of the unary-operators: \!, +, -

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/base-tools/base-tools.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Wed Dec 15 08:15:40 2010
@@ -45,13 +45,15 @@
     (let* ((result-set-boundings (set-boundings construct query-string))
 	   (filter-string (getf result-set-boundings :filter-string))
 	   (next-query (getf result-set-boundings :next-query))
+	   (filter-string-unary-ops (set-unary-operators construct filter-string))
 	   ))))
   ;;TODO: implement
+  ;; *replace #comment => in set boundings
   ;; **replace () by (progn )
   ;; **replace ', """, ''' by '''
-  ;; *replace !x by (not x)
-  ;; *replace +x by (1+ x)
-  ;; *replace -x by (1- x)
+  ;; **replace !x by (not x)
+  ;; **replace +x by (1+ x)
+  ;; **replace -x by (1- x)
   ;; *replace x operator y by (filter-operator x y)
   ;;   *=, !=, <, >, <=, >=, +, -, *, /, ||, &&
   ;; *replace function(x), function(x, y), function(x, y, z)
@@ -59,6 +61,171 @@
   ;; *create and store this filter object
 
 
+(defgeneric set-unary-operators (construct filter-string)
+  (:documentation "Transforms the unary operators !, +, - to (not ),
+                   (1+ ) and (1- ). The return value is a modified filter
+                   string.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((result-string ""))
+      (dotimes (idx (length filter-string))
+	(let ((current-char (subseq filter-string idx (1+ idx))))
+	  (cond ((string= current-char "!")
+		 (if (and (< idx (1- (length filter-string)))
+			  (string= (subseq filter-string (1+ idx) (+ 2 idx)) "="))
+		     (push-string current-char result-string)
+		     (let ((result (unary-operator-scope filter-string idx)))
+		       (push-string "(not " result-string)
+		       (push-string (set-unary-operators construct (getf result :scope))
+				    result-string)
+		       (push-string ")" result-string)
+		       (setf idx (- (1- (length filter-string))
+				    (length (getf result :next-query)))))))
+		((or (string= current-char "-")
+		     (string= current-char "+"))
+		 (let ((string-before
+			(trim-whitespace-right (subseq filter-string 0 idx))))
+		   (if (or (string= string-before "")
+			   (string-ends-with string-before "(progn")
+			   (string-ends-with-one-of string-before
+						    *supported-operators*))
+		       (let ((result (unary-operator-scope filter-string idx)))
+			 (push-string (concatenate 'string "(1" current-char " ")
+				      result-string)
+			 (push-string (set-unary-operators construct
+							   (getf result :scope))
+				      result-string)
+			 (push-string ")" result-string)
+			 (setf idx (- (1- (length filter-string))
+				      (length (getf result :next-query)))))
+		       (push-string current-char result-string))))
+		(t
+		 (push-string current-char result-string)))))
+      result-string)))
+
+
+(defun unary-operator-scope (filter-string idx)
+  "Returns a list of the form (:next-query <string> :scope <string>).
+   scope contains the statement that is in the scope of one of the following
+   operators !, +, -."
+  (declare (String filter-string)
+	   (Integer idx))
+  (let* ((string-after (subseq filter-string (1+ idx)))
+	 (cleaned-str (cut-comment string-after)))
+    (cond ((string-starts-with cleaned-str "(")
+	   (let ((result (bracket-scope cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  ((or (string-starts-with "?" cleaned-str)
+	       (string-starts-with "$" cleaned-str))
+	   (let ((result (get-filter-variable cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  ((string-starts-with "'''" cleaned-str)
+	   (let ((result (get-literal cleaned-str)))
+	     (list :next-query (getf result :next-query)
+		   :scope (getf result :literal))))
+	  ((string-starts-with-digit cleaned-str)
+	   (separate-leading-digits cleaned-str))
+	  ((string-starts-with "true" cleaned-str)
+	   (list :next-query (string-after cleaned-str "true")
+		 :scope "true"))
+	  ((string-starts-with "false" cleaned-str)
+	   (list :next-query (string-after cleaned-str "false")
+		 :scope "false"))
+	  ((let ((pos (search-first *supported-functions* cleaned-str)))
+	     (when pos
+	       (= pos 0)))
+	   (let ((result (function-scope cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  (t
+	   (error
+	    (make-condition
+	     'sparql-parser-error
+	     :message
+	     (format
+	      nil "Invalid filter: \"~a\". An unary operator must be followed by ~a"
+	      filter-string
+	      "a number, boolean, string, function or a variable")))))))
+
+
+(defun function-scope (str)
+  "If str starts with a supported function it there is given the entire substr
+   that is the scope of the function, i.e. the function name and all its
+   variable including the closing )."
+  (declare (String str))
+  (let* ((cleaned-str (cut-comment str))
+	 (after-fun
+	  (remove-null (map 'list #'(lambda(fun)
+				      (when (string-starts-with cleaned-str fun)
+					(string-after str fun)))
+			    *supported-functions*)))
+	 (fun-suffix (when after-fun
+		       (cut-comment (first after-fun)))))
+    (when fun-suffix
+      (let* ((args (bracket-scope fun-suffix))
+	     (fun-name (string-until cleaned-str args)))
+	(concatenate 'string fun-name args)))))
+
+
+(defun get-filter-variable (str)
+  "Returns the substring of str if str starts with ? or $ until the variable ends,
+   otherwise the return value is nil."
+  (declare (String str))
+  (when (or (string-starts-with str "?")
+	    (string-starts-with str "$"))
+    (let ((found-end (search-first (append (white-space) *supported-operators*
+					   *supported-brackets* (list "?" "$"))
+				   (subseq str 1))))
+      (if found-end
+	  (subseq str 0 (1+ found-end))
+	  str))))
+
+
+(defun bracket-scope (str &key (open-bracket "(") (close-bracket ")"))
+  "If str starts with open-bracket there will be returned the substring until
+   the matching close-bracket is found. Otherwise the return value is nil."
+  (declare (String str open-bracket close-bracket))
+  (when (string-starts-with str open-bracket)
+    (let ((open-brackets 0)
+	  (result ""))
+      (dotimes (idx (length str))
+	(let ((current-char (subseq str idx (1+ idx))))
+	  (cond ((or (string= "'" current-char)
+		     (string= "\"" current-char))
+		 (let* ((sub-str (subseq str idx))
+			(quotation
+			 (cond ((string-starts-with sub-str "'''")
+				"'''")
+			       ((string-starts-with sub-str "\"\"\"")
+				"\"\"\"")
+			       ((string-starts-with sub-str "'")
+				"'")
+			       ((string-starts-with sub-str "\"")
+				"\"")))
+			(literal
+			 (get-literal (subseq str idx) :quotation quotation)))
+		   (if literal
+		       (progn
+			 (setf idx (- (1- (length str))
+				      (length (getf literal :next-query))))
+			 (push-string (getf literal :literal) str))
+		       (progn
+			 (setf result nil)
+			 (setf idx (length str))))))
+		((string= current-char close-bracket)
+		 (decf open-brackets)
+		 (push-string current-char result)
+		 (when (= open-brackets 0)
+		   (setf idx (length str))))
+		((string= current-char open-bracket)
+		 (incf open-brackets)
+		 (push-string current-char result))
+		(t
+		 (push-string current-char result)))))
+      result)))
+
+
 (defgeneric set-boundings (construct query-string)
   (:documentation "Returns a list of the form (:next-query <string>
                    :filter-string <string>). next-query is a string containing
@@ -80,19 +247,20 @@
 		((string= ")" current-char)
 		 (setf open-brackets (1- open-brackets))
 		 (when (< open-brackets 0)
-		   (make-sparql-parser-condition
-		    (subseq query-string idx)
-		    (original-query construct)
-		    "an opening bracket \"(\" is missing for the current closing one"))
+		   (error
+		    (make-sparql-parser-condition
+		     (subseq query-string idx)
+		     (original-query construct)
+		     "an opening bracket \"(\" is missing for the current closing one")))
 		 (push-string current-char filter-string))
 		((or (string= "'" current-char)
 		     (string= "\"" current-char))
 		 (let ((result (get-literal (subseq query-string idx))))
 		   (unless result
-		     (make-sparql-parser-condition
-		      (subseq query-string idx)
-		      (original-query construct)
-		      "a closing character for the given literal"))
+		     (error (make-sparql-parser-condition
+			     (subseq query-string idx)
+			     (original-query construct)
+			     "a closing character for the given literal")))
 		   (setf idx (- (1- (length query-string))
 				(length (getf result :next-query))))
 		   (push-string (getf result :literal) filter-string)))
@@ -109,10 +277,10 @@
 		 (setf idx (1- (length query-string))))
 		((string= current-char "}")
 		 (when (/= open-brackets 0)
-		   (make-sparql-parser-condition
-		    (subseq query-string idx)
-		    (original-query construct)
-		    "a valid filter, but the filter is not complete"))
+		   (error (make-sparql-parser-condition
+			   (subseq query-string idx)
+			   (original-query construct)
+			   "a valid filter, but the filter is not complete")))
 		 (setf result
 		       (list :next-query (subseq query-string idx)
 			     :filter-string filter-string)))
@@ -177,29 +345,30 @@
 	    t))))
 
 
-(defun get-literal (query-string)
+(defun get-literal (query-string &key (quotation "'''"))
   "Returns a list of the form (:next-query <string> :literal <string>
    where next-query is the query after the found literal and literal
    is the literal string."
-  (declare (String query-string))
+  (declare (String query-string)
+	   (String quotation))
   (cond ((or (string-starts-with query-string "\"\"\"")
 	     (string-starts-with query-string "'''"))
 	 (let ((literal-end
 		(find-literal-end (subseq query-string 3) (subseq query-string 0 3))))
 	   (when literal-end
 	     (list :next-query (subseq query-string (+ 3 literal-end))
-		   :literal (concatenate 'string "'''"
+		   :literal (concatenate 'string quotation
 					 (subseq query-string 3 literal-end)
-					 "'''")))))
+					 quotation)))))
 	((or (string-starts-with query-string "\"")
 	     (string-starts-with query-string "'"))
 	 (let ((literal-end
 		(find-literal-end (subseq query-string 1)(subseq query-string 0 1))))
 	   (when literal-end
 	     (list :next-query (subseq query-string (+ 1 literal-end))
-		   :literal (concatenate 'string "'''"
+		   :literal (concatenate 'string quotation
 					 (subseq query-string 1 literal-end)
-					 "'''")))))))
+					 quotation)))))))
 
 
 (defun find-literal-end (query-string delimiter &optional (overall-pos 0))

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Wed Dec 15 08:15:40 2010
@@ -19,17 +19,33 @@
 	   :trim-whitespace
 	   :string-starts-with
 	   :string-ends-with
+	   :string-ends-with-one-of
 	   :string-starts-with-char
 	   :string-until
 	   :string-after
 	   :search-first
 	   :concatenate-uri
 	   :absolute-uri-p
-	   :string-starts-with-digit))
+	   :string-starts-with-digit
+	   :string-after-number
+	   :separate-leading-digits
+	   :white-space))
 
 (in-package :base-tools)
 
 
+(defparameter *white-space*
+  (list #\Space #\Tab #\Newline #\cr)
+  "Contains all characters that are treated as white space.")
+
+
+(defun white-space()
+  "Returns a lit os string that represents a white space."
+  (map 'list #'(lambda(char)
+		 (string char))
+       *white-space*))
+
+
 (defmacro push-string (obj place)
   "Imitates the push macro but instead of pushing object in a list,
    there will be appended the given string to the main string object."
@@ -70,19 +86,19 @@
 (defun trim-whitespace-left (value)
   "Uses string-left-trim with a predefined character-list."
   (declare (String value))
-  (string-left-trim '(#\Space #\Tab #\Newline #\cr) value))
+  (string-left-trim *white-space* value))
 
 
 (defun trim-whitespace-right (value)
   "Uses string-right-trim with a predefined character-list."
   (declare (String value))
-  (string-right-trim '(#\Space #\Tab #\Newline #\cr) value))
+  (string-right-trim *white-space* value))
 
 
 (defun trim-whitespace (value)
   "Uses string-trim with a predefined character-list."
   (declare (String value))
-  (string-trim '(#\Space #\Tab #\Newline #\cr) value))
+  (string-trim *white-space* value))
 
 
 (defun string-starts-with (str prefix &key (ignore-case nil))
@@ -119,6 +135,16 @@
 					 0))))
 
 
+(defun string-ends-with-one-of (str suffixes &key (ignore-case nil))
+  "Returns t if str ends with one of the string contained in suffixes."
+  (declare (String str)
+	   (List suffixes)
+	   (Boolean ignore-case))
+  (loop for suffix in suffixes
+     when (string-ends-with str suffix :ignore-case ignore-case)
+     return t))
+
+
 (defun string-starts-with-digit (str)
   "Checks whether the passed string starts with a digit."
   (declare (String str))
@@ -126,6 +152,26 @@
      when (string-starts-with str (write-to-string item))
      return t))
 
+(defun string-after-number (str)
+  "If str starts with a digit, there is returned the first
+   substring after a character that is a non-digit.
+   If str does not start with a digit str is returned."
+  (declare (String str))
+  (if (and (string-starts-with-digit str)
+	   (> (length str) 0))
+      (string-after-number (subseq str 1))
+      str))
+
+
+(defun separate-leading-digits (str &optional digits)
+  "If str starts with a number the number is returned."
+  (declare (String str)
+	   (type (or Null String) digits))
+  (if (string-starts-with-digit str)
+      (separate-leading-digits
+       (subseq str 1) (concatenate 'string digits (subseq str 0 1)))
+      digits))
+
 
 (defun string-starts-with-char (begin str)
   (equal (char str 0) begin))



From lgiessmann at common-lisp.net  Wed Dec 15 18:08:02 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 15 Dec 2010 13:08:02 -0500
Subject: [isidorus-cvs] r365 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1PSvli-0000rL-2O@common-lisp.net>

Author: lgiessmann
Date: Wed Dec 15 13:08:01 2010
New Revision: 365

Log:
TM-SPARQL: added some unit-tests for the handling of \!, -, + as unary opertors => fixed some bugs

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Wed Dec 15 13:08:01 2010
@@ -58,6 +58,7 @@
   ;;   *=, !=, <, >, <=, >=, +, -, *, /, ||, &&
   ;; *replace function(x), function(x, y), function(x, y, z)
   ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
+  ;; check if all functions that will e invoked are allowed
   ;; *create and store this filter object
 
 
@@ -115,21 +116,23 @@
 	   (let ((result (bracket-scope cleaned-str)))
 	     (list :next-query (string-after cleaned-str result)
 		   :scope result)))
-	  ((or (string-starts-with "?" cleaned-str)
-	       (string-starts-with "$" cleaned-str))
+	  ((or (string-starts-with cleaned-str "?")
+	       (string-starts-with cleaned-str "$"))
 	   (let ((result (get-filter-variable cleaned-str)))
 	     (list :next-query (string-after cleaned-str result)
 		   :scope result)))
-	  ((string-starts-with "'''" cleaned-str)
+	  ((string-starts-with cleaned-str "'''")
 	   (let ((result (get-literal cleaned-str)))
 	     (list :next-query (getf result :next-query)
 		   :scope (getf result :literal))))
 	  ((string-starts-with-digit cleaned-str)
-	   (separate-leading-digits cleaned-str))
-	  ((string-starts-with "true" cleaned-str)
+	   (let ((result (separate-leading-digits cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  ((string-starts-with cleaned-str "true")
 	   (list :next-query (string-after cleaned-str "true")
 		 :scope "true"))
-	  ((string-starts-with "false" cleaned-str)
+	  ((string-starts-with cleaned-str "false")
 	   (list :next-query (string-after cleaned-str "false")
 		 :scope "false"))
 	  ((let ((pos (search-first *supported-functions* cleaned-str)))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Dec 15 13:08:01 2010
@@ -30,7 +30,8 @@
 	   :test-set-result-4
 	   :test-set-result-5
 	   :test-result
-	   :test-set-boundings))
+	   :test-set-boundings
+	   :test-set-unary-operators))
 
 
 (in-package :sparql-test)
@@ -1073,5 +1074,44 @@
 		 "DATATYPE(?var3) ||(progn isLITERAL  (+?var1 = -?var2))"))
     (is (string= (getf result-5 :next-query) "}"))))
 
+
+(test test-set-unary-operators
+  "Tests various cases of the function set-unary-operators."
+  (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
+	 (str-1 "BOUND(?var1)||(!(+(-(?var1))))}")
+	 (str-2 "!BOUND(?var1) = false}")
+	 (str-3 "+?var1=-$var2}")
+	 (str-4 "!'abc' && (+12 = - 14)}")
+	 (result-1
+	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+	 (result-1-1 (tm-sparql::set-unary-operators dummy-object result-1))
+	 (result-2
+	  (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+	 (result-2-1 (tm-sparql::set-unary-operators dummy-object result-2))
+	 (result-3
+	  (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
+	 (result-3-1
+	  (tm-sparql::set-unary-operators dummy-object result-3))
+	 (result-4
+	  (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
+	 (result-4-1
+	  (tm-sparql::set-unary-operators dummy-object result-4)))
+    (is-true result-1)
+    (is-true result-1-1)
+    (is-true result-2)
+    (is-true result-2-1)
+    (is-true result-3)
+    (is-true result-3-1)
+    (is-true result-4)
+    (is-true result-4-1)
+    (is (string=
+	 result-1-1
+	 "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))"))
+    (is (string= result-2-1 "(not BOUND(?var1)) = false"))
+    (is (string= result-3-1 "(1+ ?var1)=(1- $var2)"))
+    (is (string= result-4-1 "(not '''abc''') && (progn (1+ 12) = (1- 14))"))))
+	 
+
+
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Thu Dec 16 13:23:10 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 16 Dec 2010 08:23:10 -0500
Subject: [isidorus-cvs] r366 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1PTDna-000394-Bj@common-lisp.net>

Author: lgiessmann
Date: Thu Dec 16 08:23:10 2010
New Revision: 366

Log:
TM-SPARQL: fixed a problem in all filter statements that uses """, ' or ''' and do not escape inner " in literals

Modified:
   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/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Thu Dec 16 08:23:10 2010
@@ -58,7 +58,9 @@
   ;;   *=, !=, <, >, <=, >=, +, -, *, /, ||, &&
   ;; *replace function(x), function(x, y), function(x, y, z)
   ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
-  ;; check if all functions that will e invoked are allowed
+  ;; check if all functions that will be invoked are allowed
+  ;; add a let with all variables that are used: every variable with $ and ? prefix
+  ;; add a let with (true t) and (false nil)
   ;; *create and store this filter object
 
 
@@ -121,7 +123,7 @@
 	   (let ((result (get-filter-variable cleaned-str)))
 	     (list :next-query (string-after cleaned-str result)
 		   :scope result)))
-	  ((string-starts-with cleaned-str "'''")
+	  ((string-starts-with cleaned-str "\"")
 	   (let ((result (get-literal cleaned-str)))
 	     (list :next-query (getf result :next-query)
 		   :scope (getf result :literal))))
@@ -348,7 +350,7 @@
 	    t))))
 
 
-(defun get-literal (query-string &key (quotation "'''"))
+(defun get-literal (query-string &key (quotation "\""))
   "Returns a list of the form (:next-query <string> :literal <string>
    where next-query is the query after the found literal and literal
    is the literal string."
@@ -366,12 +368,14 @@
 	((or (string-starts-with query-string "\"")
 	     (string-starts-with query-string "'"))
 	 (let ((literal-end
-		(find-literal-end (subseq query-string 1)(subseq query-string 0 1))))
+		(find-literal-end (subseq query-string 1)
+				  (subseq query-string 0 1))))
 	   (when literal-end
-	     (list :next-query (subseq query-string (+ 1 literal-end))
-		   :literal (concatenate 'string quotation
-					 (subseq query-string 1 literal-end)
-					 quotation)))))))
+	     (let ((literal
+		    (escape-string (subseq query-string 1 literal-end) "\"")))
+	       (list :next-query (subseq query-string (+ 1 literal-end))
+		     :literal (concatenate 'string quotation literal
+					   quotation))))))))
 
 
 (defun find-literal-end (query-string delimiter &optional (overall-pos 0))

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Thu Dec 16 08:23:10 2010
@@ -29,7 +29,8 @@
 	   :string-starts-with-digit
 	   :string-after-number
 	   :separate-leading-digits
-	   :white-space))
+	   :white-space
+	   :escape-string))
 
 (in-package :base-tools)
 
@@ -260,4 +261,21 @@
 	   (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
+	   (not (find #\/ (subseq uri 0 position-of-colon)))))))
+
+
+(defun escape-string (str char-to-escape)
+  "Escapes every occurrence of char-to-escape in str, if it is
+   not escaped."
+  (declare (String str char-to-escape))
+  (let ((result ""))
+    (dotimes (idx (length str))
+      (let ((current-char (subseq str idx (1+ idx)))
+	    (previous-char (if (= idx 0) "" (subseq str (1- idx) idx))))
+	(cond ((and (string= current-char char-to-escape)
+		    (string/= previous-char "\\"))
+	       (push-string "\\" result)
+	       (push-string current-char result))
+	      (t
+	       (push-string current-char result)))))
+    result))
\ No newline at end of file

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Thu Dec 16 08:23:10 2010
@@ -1059,10 +1059,10 @@
     (is-true result-1)
     (is-true result-2)
     (is (string= (getf result-1 :filter-string)
-		 "BOUND((progn   (progn ?var)  )) || (progn isLITERAL($var) && ?var = '''abc''')"))
+		 "BOUND((progn   (progn ?var)  )) || (progn isLITERAL($var) && ?var = \"abc\")"))
     (is (string= (getf result-1 :next-query) "}"))
     (is (string= (getf result-2 :filter-string)
-		 "(progn REGEX(?var1, '''''', ?var3) || (progn ?var1 > ?var3 && (progn STR( ?var) = '''abc''')))"))
+		 "(progn REGEX(?var1, \"\", ?var3) || (progn ?var1 > ?var3 && (progn STR( ?var) = \"abc\")))"))
     (is (string= (getf result-2 :next-query) "}"))
     (is (string= (getf result-3 :filter-string)
 		 "DATATYPE(?var3) || +?var1 = -?var2"))
@@ -1081,7 +1081,7 @@
 	 (str-1 "BOUND(?var1)||(!(+(-(?var1))))}")
 	 (str-2 "!BOUND(?var1) = false}")
 	 (str-3 "+?var1=-$var2}")
-	 (str-4 "!'abc' && (+12 = - 14)}")
+	 (str-4 "!'a\"b\"c' && (+12 = - 14)}")
 	 (result-1
 	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
 	 (result-1-1 (tm-sparql::set-unary-operators dummy-object result-1))
@@ -1109,7 +1109,7 @@
 	 "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))"))
     (is (string= result-2-1 "(not BOUND(?var1)) = false"))
     (is (string= result-3-1 "(1+ ?var1)=(1- $var2)"))
-    (is (string= result-4-1 "(not '''abc''') && (progn (1+ 12) = (1- 14))"))))
+    (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))"))))
 	 
 
 



From lgiessmann at common-lisp.net  Thu Dec 16 21:07:41 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 16 Dec 2010 16:07:41 -0500
Subject: [isidorus-cvs] r367 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1PTL37-0003wR-EO@common-lisp.net>

Author: lgiessmann
Date: Thu Dec 16 16:07:40 2010
New Revision: 367

Log:
TM-SPARQL: adde the hanlding of || and && operators; added also some unit-tests for these cases

Modified:
   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/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Thu Dec 16 16:07:40 2010
@@ -15,10 +15,19 @@
   "Contains all supported SPARQL-functions")
 
 
-(defparameter *supported-operators*
-  (list "!" "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/")
-  "Contains all supported operators, note some unary operators
-   are handled as functions, e.g. + and -")
+(defparameter *supported-binary-operators*
+  (list "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/")
+  "Contains all supported binary operators.")
+
+
+(defparameter *supported-unary-operators*
+  (list "!" "+" "-") "Contains all supported unary operators")
+
+
+(defun *supported-operators* ()
+  (union *supported-binary-operators* *supported-unary-operators*
+	 :test #'string=))
+
 
 (defparameter *supported-brackets*
   (list "(" ")")
@@ -45,25 +54,115 @@
     (let* ((result-set-boundings (set-boundings construct query-string))
 	   (filter-string (getf result-set-boundings :filter-string))
 	   (next-query (getf result-set-boundings :next-query))
-	   (filter-string-unary-ops (set-unary-operators construct filter-string))
+	   (filter-string-unary-ops
+	    (set-unary-operators construct filter-string))
+	   (filter-string-or-and-ops
+	    (set-or-and-operators construct filter-string-unary-ops))
 	   ))))
   ;;TODO: implement
-  ;; *replace #comment => in set boundings
   ;; **replace () by (progn )
-  ;; **replace ', """, ''' by '''
+  ;; **replace ', """, ''' by "
   ;; **replace !x by (not x)
   ;; **replace +x by (1+ x)
   ;; **replace -x by (1- x)
-  ;; *replace x operator y by (filter-operator x y)
-  ;;   *=, !=, <, >, <=, >=, +, -, *, /, ||, &&
+  ;; **||, &&
+  ;; *=, !=, <, >, <=, >=, +, -, *, /
   ;; *replace function(x), function(x, y), function(x, y, z)
   ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
-  ;; check if all functions that will be invoked are allowed
-  ;; add a let with all variables that are used: every variable with $ and ? prefix
-  ;; add a let with (true t) and (false nil)
+  ;; *check if all functions that will be invoked are allowed
+  ;; *add a let with all variables that are used: every variable with $ and ? prefix
+  ;; *add a let with (true t) and (false nil)
+  ;; *embrace the final result uris in <> => unit-tests
   ;; *create and store this filter object
 
 
+(defgeneric set-or-and-operators (construct filter-string)
+  (:documentation "Transforms the || and && operators in the filter string to
+                   the the lisp or and and functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((op-pos (search-first (list "||" "&&") filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos)))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (+ 2 op-pos)))
+		 (left-scope (find-or-and-left-scope left-str))
+		 (right-scope (find-or-and-right-scope right-str))
+		 (modified-str
+		  (concatenate 'string (subseq left-str 0 (- (length left-str)
+							     (length left-scope)))
+			       "(" (if (string= op-str "||") "or" "and") " "
+			       "(progn " left-scope ")" "(progn " right-scope ")) "
+			       (subseq right-str (length right-scope)))))
+	    (set-or-and-operators construct modified-str))))))
+
+
+(defun find-binary-op-string (filter-string idx)
+  "Returns the operator as string that is placed on the position idx."
+  (let* ((2-ops
+	  (remove-null (map 'list #'(lambda(op-string)
+				      (when (= (length op-string) 2)
+					op-string))
+			    *supported-binary-operators*)))
+	 (operator-str (subseq filter-string idx)))
+    (if (string-starts-with-one-of operator-str 2-ops)
+	(subseq operator-str 0 2)
+	(subseq operator-str 0 1))))
+
+
+(defun find-or-and-left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value 
+	      (+ inner-value (1+ (length (name-after-paranthesis
+					  (subseq left-string inner-value))))))))
+	 (start-idx (if first-bracket
+			first-bracket
+			0)))
+    (subseq left-string start-idx)))
+
+
+(defun name-after-paranthesis (str)
+  "Returns the substring that is contained after the paranthesis.
+   str must start with a ( otherwise the returnvalue is nil."
+  (declare (String str))
+  (let ((result "")
+	(non-whitespace-found nil))
+  (when (string-starts-with str "(")
+    (let ((cleaned-str (subseq str 1)))
+      (dotimes (idx (length cleaned-str))
+	(let ((current-char (subseq cleaned-str idx (1+ idx))))
+	  (cond ((string-starts-with-one-of current-char (list "(" ")"))
+		 (setf idx (length cleaned-str)))
+		((and non-whitespace-found
+		      (white-space-p current-char))
+		 (setf idx (length cleaned-str)))
+		((white-space-p current-char)
+		 (push-string current-char result))
+		(t
+		 (push-string current-char result)
+		 (setf non-whitespace-found t)))))
+      result))))
+
+
+(defun find-or-and-right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  (let* ((first-pos (search-first (list "||" "&&") right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (end-idx (cond ((and first-pos first-bracket)
+			 (min first-pos first-bracket))
+			(first-pos first-pos)
+			(first-bracket first-bracket)
+			(t (if (= (length right-string) 0)
+			       (1- (length right-string)))))))
+    (subseq right-string 0 end-idx)))
+
+
 (defgeneric set-unary-operators (construct filter-string)
   (:documentation "Transforms the unary operators !, +, - to (not ),
                    (1+ ) and (1- ). The return value is a modified filter
@@ -90,7 +189,7 @@
 		   (if (or (string= string-before "")
 			   (string-ends-with string-before "(progn")
 			   (string-ends-with-one-of string-before
-						    *supported-operators*))
+						    (*supported-operators*)))
 		       (let ((result (unary-operator-scope filter-string idx)))
 			 (push-string (concatenate 'string "(1" current-char " ")
 				      result-string)
@@ -179,7 +278,7 @@
   (declare (String str))
   (when (or (string-starts-with str "?")
 	    (string-starts-with str "$"))
-    (let ((found-end (search-first (append (white-space) *supported-operators*
+    (let ((found-end (search-first (append (white-space) (*supported-operators*)
 					   *supported-brackets* (list "?" "$"))
 				   (subseq str 1))))
       (if found-end
@@ -301,7 +400,7 @@
 	   (Integer idx))
   (let* ((delimiters (append (list " " (string #\Space) (string #\Tab)
 				   (string #\Newline) (string #\cr) "(" ")")
-			     *supported-operators*))
+			     (*supported-operators*)))
 	 (string-before (trim-whitespace-right (subseq query-string 0 idx)))
 	 (fragment-before-idx
 	  (search-first delimiters string-before :from-end t))
@@ -323,7 +422,7 @@
 			     (> (length fragment-before) (length operator)))
 		    (setf fragment-before
 			  (string-after fragment-before operator))))
-	      (append *supported-operators* *supported-brackets*)))
+	      (append (*supported-operators*) *supported-brackets*)))
     (if fragment-before
 	(progn
 	  (when (or (string-starts-with fragment-before "?")

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Thu Dec 16 16:07:40 2010
@@ -12,6 +12,7 @@
   (:nicknames :tools)
   (:export :push-string
 	   :when-do
+	   :string-replace
 	   :remove-null
 	   :full-path
 	   :trim-whitespace-left
@@ -21,6 +22,7 @@
 	   :string-ends-with
 	   :string-ends-with-one-of
 	   :string-starts-with-char
+	   :string-starts-with-one-of
 	   :string-until
 	   :string-after
 	   :search-first
@@ -30,7 +32,10 @@
 	   :string-after-number
 	   :separate-leading-digits
 	   :white-space
-	   :escape-string))
+	   :white-space-p
+	   :escape-string
+	   :search-first-unclosed-paranthesis 
+	   :search-first-unopened-paranthesis ))
 
 (in-package :base-tools)
 
@@ -63,6 +68,17 @@
 	 nil)))
 
 
+(defun white-space-p (str)
+  "Returns t if the passed str contains only white space characters."
+  (cond ((and (= (length str) 1)
+	      (string-starts-with-one-of str (white-space)))
+	 t)
+	((string-starts-with-one-of str (white-space))
+	 (white-space-p (subseq str 1)))
+	(t
+	 nil)))
+
+
 (defun remove-null (lst)
   "Removes all null values from the passed list."
   (remove-if #'null lst))
@@ -118,6 +134,16 @@
 		  (length str-i)))))
 
 
+(defun string-starts-with-one-of (str prefixes &key (ignore-case nil))
+  "Returns t if str ends with one of the string contained in suffixes."
+  (declare (String str)
+	   (List prefixes)
+	   (Boolean ignore-case))
+  (loop for prefix in prefixes
+     when (string-starts-with str prefix :ignore-case ignore-case)
+     return t))
+
+
 (defun string-ends-with (str suffix &key (ignore-case nil))
   "Checks if string str ends with a given suffix."
   (declare (String str suffix)
@@ -146,6 +172,23 @@
      return t))
 
 
+(defun string-replace (main-string string-to-replace new-string)
+  "Replaces every occurrence of string-to-replace by new-string
+   in main-string."
+  (declare (String main-string string-to-replace new-string))
+  (if (string= string-to-replace new-string)
+      main-string
+      (let ((search-idx (search-first (list string-to-replace) main-string)))
+	(if (not search-idx)
+	    main-string
+	    (let ((modified-string
+		   (concatenate 'string (subseq main-string 0 search-idx)
+				new-string (subseq main-string
+						   (+ search-idx (length string-to-replace))))))
+	      (string-replace modified-string string-to-replace new-string))))))
+
+
+
 (defun string-starts-with-digit (str)
   "Checks whether the passed string starts with a digit."
   (declare (String str))
@@ -153,6 +196,7 @@
      when (string-starts-with str (write-to-string item))
      return t))
 
+
 (defun string-after-number (str)
   "If str starts with a digit, there is returned the first
    substring after a character that is a non-digit.
@@ -278,4 +322,41 @@
 	       (push-string current-char result))
 	      (t
 	       (push-string current-char result)))))
-    result))
\ No newline at end of file
+    result))
+
+
+(defun search-first-unclosed-paranthesis (str)
+  "Returns the idx of the first ( that is not closed, the search is
+   started from the end of the string."
+  (declare (String str))
+  (let ((r-str (reverse str))
+	(open-brackets 0)
+	(result-idx nil))
+    (dotimes (idx (length r-str))
+      (let ((current-char (subseq r-str idx (1+ idx))))
+	(cond ((string= current-char ")")
+	       (decf open-brackets))
+	      ((string= current-char "(")
+	       (incf open-brackets)
+	       (when (> open-brackets 0)
+		 (setf result-idx idx)
+		 (setf idx (length r-str)))))))
+    (when result-idx
+      (- (length str) (1+ result-idx)))))
+
+
+(defun search-first-unopened-paranthesis (str)
+  "Returns the idx of the first paranthesis that is not opened in str."
+  (declare (String str))
+  (let ((closed-brackets 0)
+	(result-idx nil))
+    (dotimes (idx (length str))
+      (let ((current-char (subseq str idx (1+ idx))))
+	(cond ((string= current-char "(")
+	       (decf closed-brackets))
+	      ((string= current-char ")")
+	       (incf closed-brackets)
+	       (when (> closed-brackets 0)
+		 (setf result-idx idx)
+		 (setf idx (length str)))))))
+    result-idx))
\ No newline at end of file

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Thu Dec 16 16:07:40 2010
@@ -9,6 +9,7 @@
 
 (defpackage :sparql-test
   (:use  :cl
+	 :base-tools
 	 :it.bese.FiveAM
 	 :TM-SPARQL
 	 :exceptions
@@ -31,7 +32,8 @@
 	   :test-set-result-5
 	   :test-result
 	   :test-set-boundings
-	   :test-set-unary-operators))
+	   :test-set-unary-operators
+	   :test-set-or-and-operators))
 
 
 (in-package :sparql-test)
@@ -1112,6 +1114,26 @@
     (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))"))))
 	 
 
+(test test-set-or-and-operators
+  "Tests various cases of the function set-unary-operators."
+  (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
+	 (str-1 "isLITERAL(STR(?var))||?var = 12 && true}")
+	 (str-2 "(true != false || !false ) && 12 < 14 || !isLITERAL(?var)}")
+	 (result-1
+	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+	 (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1))
+	 (result-2
+	  (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+	 (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2)))
+    (is-true result-1)
+    (is-true result-1-1)
+    (is-true result-2)
+    (is-true result-2-1)
+    (is (string= (string-replace result-1-1 " " "")
+		 "(and(progn(or(prognisLITERAL(STR(?var)))(progn?var=12)))(progntrue))"))
+    (is (string= (string-replace result-2-1 " " "")
+		 "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))"))))
+    
 
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Fri Dec 17 11:55:26 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 17 Dec 2010 06:55:26 -0500
Subject: [isidorus-cvs] r368 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1PTYuE-0000Sn-5l@common-lisp.net>

Author: lgiessmann
Date: Fri Dec 17 06:55:25 2010
New Revision: 368

Log:
TM-SPARQL: fixed a bug with ||, &&, \!, unary + and - operators => when these operators are contained within literal-strings they are not evaluated anymore => extended the corresponding unit-tests.

Modified:
   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/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Fri Dec 17 06:55:25 2010
@@ -57,7 +57,11 @@
 	   (filter-string-unary-ops
 	    (set-unary-operators construct filter-string))
 	   (filter-string-or-and-ops
-	    (set-or-and-operators construct filter-string-unary-ops))
+	    (set-or-and-operators construct filter-string-unary-ops
+				  filter-string-unary-ops))
+	   (filter-string-binary-ops
+	    (set-binary-operators construct filter-string-or-and-ops))
+	    
 	   ))))
   ;;TODO: implement
   ;; **replace () by (progn )
@@ -76,11 +80,21 @@
   ;; *create and store this filter object
 
 
-(defgeneric set-or-and-operators (construct filter-string)
+(defgeneric set-binary-operators (construct filter-string)
+  (:documentation "Transforms the =, !=, <, >, <=, >=, +, -, *, / operators
+                   in the filter string to the the lisp =, /=, <, >, <=, >=,
+                   +, -, * and / functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    ;TODO: implement
+    ))
+
+
+(defgeneric set-or-and-operators (construct filter-string original-filter-string)
   (:documentation "Transforms the || and && operators in the filter string to
                    the the lisp or and and functions.")
-  (:method ((construct SPARQL-Query) (filter-string String))
-    (let ((op-pos (search-first (list "||" "&&") filter-string)))
+  (:method ((construct SPARQL-Query) (filter-string String)
+	    (original-filter-string String))
+    (let ((op-pos (search-first-ignore-literals (list "||" "&&") filter-string)))
       (if (not op-pos)
 	  filter-string
 	  (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos)))
@@ -94,7 +108,12 @@
 			       "(" (if (string= op-str "||") "or" "and") " "
 			       "(progn " left-scope ")" "(progn " right-scope ")) "
 			       (subseq right-str (length right-scope)))))
-	    (set-or-and-operators construct modified-str))))))
+	    (when (or (= (length (trim-whitespace left-scope)) 0)
+		      (= (length (trim-whitespace right-scope)) 0))
+	      (error (make-condition
+		      'sparql-parser-error
+		      :message (format nil "Invalid filter: \"~a\", expect an RDF term after and before: \"~a\"" original-filter-string op-str))))
+	    (set-or-and-operators construct modified-str original-filter-string))))))
 
 
 (defun find-binary-op-string (filter-string idx)
@@ -150,7 +169,7 @@
 (defun find-or-and-right-scope (right-string)
   "Returns the string that is the right part of the binary scope."
   (declare (String right-string))
-  (let* ((first-pos (search-first (list "||" "&&") right-string))
+  (let* ((first-pos (search-first-ignore-literals (list "||" "&&") right-string))
 	 (first-bracket
 	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
 	    (when inner-value (1+ inner-value))))
@@ -200,6 +219,18 @@
 			 (setf idx (- (1- (length filter-string))
 				      (length (getf result :next-query)))))
 		       (push-string current-char result-string))))
+		((or (string= current-char "'")
+		     (string= current-char "\""))
+		 (let* ((sub-str (subseq filter-string idx))
+			(quotation (get-literal-quotation sub-str))
+			(literal
+			 (get-literal (subseq filter-string idx) :quotation quotation)))
+		   (if literal
+		       (progn
+			 (setf idx (- (1- (length filter-string))
+				      (length (getf literal :next-string))))
+			 (push-string (getf literal :literal) result-string))
+		       (push-string current-char result-string))))
 		(t
 		 (push-string current-char result-string)))))
       result-string)))
@@ -224,7 +255,7 @@
 		   :scope result)))
 	  ((string-starts-with cleaned-str "\"")
 	   (let ((result (get-literal cleaned-str)))
-	     (list :next-query (getf result :next-query)
+	     (list :next-query (getf result :next-string)
 		   :scope (getf result :literal))))
 	  ((string-starts-with-digit cleaned-str)
 	   (let ((result (separate-leading-digits cleaned-str)))
@@ -298,21 +329,13 @@
 	  (cond ((or (string= "'" current-char)
 		     (string= "\"" current-char))
 		 (let* ((sub-str (subseq str idx))
-			(quotation
-			 (cond ((string-starts-with sub-str "'''")
-				"'''")
-			       ((string-starts-with sub-str "\"\"\"")
-				"\"\"\"")
-			       ((string-starts-with sub-str "'")
-				"'")
-			       ((string-starts-with sub-str "\"")
-				"\"")))
+			(quotation (get-literal-quotation sub-str))
 			(literal
 			 (get-literal (subseq str idx) :quotation quotation)))
 		   (if literal
 		       (progn
 			 (setf idx (- (1- (length str))
-				      (length (getf literal :next-query))))
+				      (length (getf literal :next-string))))
 			 (push-string (getf literal :literal) str))
 		       (progn
 			 (setf result nil)
@@ -366,7 +389,7 @@
 			     (original-query construct)
 			     "a closing character for the given literal")))
 		   (setf idx (- (1- (length query-string))
-				(length (getf result :next-query))))
+				(length (getf result :next-string))))
 		   (push-string (getf result :literal) filter-string)))
 		((string= "#" current-char)
 		 (let ((comment-string
@@ -446,50 +469,4 @@
 	      t))
 	(if (find string-before *supported-functions* :test #'string=)
 	    nil
-	    t))))
-
-
-(defun get-literal (query-string &key (quotation "\""))
-  "Returns a list of the form (:next-query <string> :literal <string>
-   where next-query is the query after the found literal and literal
-   is the literal string."
-  (declare (String query-string)
-	   (String quotation))
-  (cond ((or (string-starts-with query-string "\"\"\"")
-	     (string-starts-with query-string "'''"))
-	 (let ((literal-end
-		(find-literal-end (subseq query-string 3) (subseq query-string 0 3))))
-	   (when literal-end
-	     (list :next-query (subseq query-string (+ 3 literal-end))
-		   :literal (concatenate 'string quotation
-					 (subseq query-string 3 literal-end)
-					 quotation)))))
-	((or (string-starts-with query-string "\"")
-	     (string-starts-with query-string "'"))
-	 (let ((literal-end
-		(find-literal-end (subseq query-string 1)
-				  (subseq query-string 0 1))))
-	   (when literal-end
-	     (let ((literal
-		    (escape-string (subseq query-string 1 literal-end) "\"")))
-	       (list :next-query (subseq query-string (+ 1 literal-end))
-		     :literal (concatenate 'string quotation literal
-					   quotation))))))))
-
-
-(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 (length delimiter)))
-	nil)))
\ No newline at end of file
+	    t))))
\ 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	Fri Dec 17 06:55:25 2010
@@ -26,6 +26,7 @@
 	   :string-until
 	   :string-after
 	   :search-first
+	   :search-first-ignore-literals
 	   :concatenate-uri
 	   :absolute-uri-p
 	   :string-starts-with-digit
@@ -35,7 +36,11 @@
 	   :white-space-p
 	   :escape-string
 	   :search-first-unclosed-paranthesis 
-	   :search-first-unopened-paranthesis ))
+	   :search-first-unopened-paranthesis
+	   :in-literal-string-p
+	   :find-literal-end
+	   :get-literal-quotation
+	   :get-literal))
 
 (in-package :base-tools)
 
@@ -245,8 +250,7 @@
   "Returns the position of one of the search-strings. The returned position
    is the one closest to 0. If no search-string is found, nil is returned."
   (declare (String main-string)
-	   (List search-strings)
-	   (Boolean from-end))
+	   (List search-strings))
   (let ((positions
 	 (remove-null
 	  (map 'list #'(lambda(search-str)
@@ -259,6 +263,81 @@
 	(first sorted-positions)))))
 
 
+(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 (length delimiter)))
+	nil)))
+
+
+(defun get-literal-quotation (str)
+  "Returns ', ''', \" or \"\"\" when the string starts with a literal delimiter."
+  (cond ((string-starts-with str "'''")
+	 "'")
+	((string-starts-with str "\"\"\"")
+	 "\"\"\"")
+	((string-starts-with str "'")
+	 "'")
+	((string-starts-with str "\"")
+	 "\"")))
+
+
+(defun get-literal (query-string &key (quotation "\""))
+  "Returns a list of the form (:next-string <string> :literal <string>
+   where next-query is the query after the found literal and literal
+   is the literal string."
+  (declare (String query-string)
+	   (String quotation))
+  (cond ((or (string-starts-with query-string "\"\"\"")
+	     (string-starts-with query-string "'''"))
+	 (let ((literal-end
+		(find-literal-end (subseq query-string 3) (subseq query-string 0 3))))
+	   (when literal-end
+	     (list :next-string (subseq query-string (+ 3 literal-end))
+		   :literal (concatenate 'string quotation
+					 (subseq query-string 3 literal-end)
+					 quotation)))))
+	((or (string-starts-with query-string "\"")
+	     (string-starts-with query-string "'"))
+	 (let ((literal-end
+		(find-literal-end (subseq query-string 1)
+				  (subseq query-string 0 1))))
+	   (when literal-end
+	     (let ((literal
+		    (escape-string (subseq query-string 1 literal-end) "\"")))
+	       (list :next-string (subseq query-string (+ 1 literal-end))
+		     :literal (concatenate 'string quotation literal
+					   quotation))))))))
+
+
+(defun search-first-ignore-literals (search-strings main-string)
+  (declare (String main-string)
+	   (List search-strings))
+  (let ((first-pos (search-first search-strings main-string)))
+    (when first-pos
+      (if (not (in-literal-string-p main-string first-pos))
+	  first-pos
+	  (let* ((literal-start (search-first (list "\"" "'") main-string))
+		 (sub-str (subseq main-string literal-start))
+		 (literal-result (get-literal sub-str))
+		 (next-str (getf literal-result :next-string)))
+	    (let ((next-pos
+		   (search-first-ignore-literals search-strings next-str)))
+	      (when next-pos
+		(+ (- (length main-string) (length next-str)) next-pos))))))))
+
+
 (defun concatenate-uri (absolute-ns value)
   "Returns a string conctenated of the absolut namespace an the given value
    separated by either '#' or '/'."
@@ -325,38 +404,76 @@
     result))
 
 
-(defun search-first-unclosed-paranthesis (str)
+(defun in-literal-string-p(filter-string pos)
+  "Returns t if the passed pos is within a literal string value."
+  (declare (String filter-string)
+	   (Integer pos))
+  (let ((result nil))
+    (dotimes (idx (length filter-string) result)
+      (let ((current-char (subseq filter-string idx (1+ idx))))
+	(cond ((or (string= current-char "'")
+		   (string= current-char "\""))
+	       (let* ((l-result (get-literal (subseq filter-string idx)))
+		      (next-idx
+		       (when l-result
+			 (- (length filter-string)
+			    (length (getf l-result :next-query))))))
+		 (when (and next-idx (< pos next-idx))
+		   (setf result t)
+		   (setf idx (length filter-string)))
+		 (when (<= pos idx)
+		   (setf idx (length filter-string)))))
+	      (t
+	       (when (<= pos idx)
+		 (setf idx (length filter-string)))))))))
+
+
+(defun search-first-unclosed-paranthesis (str &key ignore-literals)
   "Returns the idx of the first ( that is not closed, the search is
-   started from the end of the string."
-  (declare (String str))
+   started from the end of the string.
+   If ignore-literals is set to t all mparanthesis that are within
+   \", \"\"\", ' and ''' are ignored."
+  (declare (String str)
+	   (Boolean ignore-literals))
   (let ((r-str (reverse str))
 	(open-brackets 0)
 	(result-idx nil))
     (dotimes (idx (length r-str))
       (let ((current-char (subseq r-str idx (1+ idx))))
 	(cond ((string= current-char ")")
-	       (decf open-brackets))
+	       (when (or ignore-literals
+			 (not (in-literal-string-p str idx)))
+		 (decf open-brackets)))
 	      ((string= current-char "(")
-	       (incf open-brackets)
-	       (when (> open-brackets 0)
-		 (setf result-idx idx)
-		 (setf idx (length r-str)))))))
+	       (when (or ignore-literals
+			 (not (in-literal-string-p str idx)))
+		 (incf open-brackets)
+		 (when (> open-brackets 0)
+		   (setf result-idx idx)
+		   (setf idx (length r-str))))))))
     (when result-idx
       (- (length str) (1+ result-idx)))))
 
 
-(defun search-first-unopened-paranthesis (str)
-  "Returns the idx of the first paranthesis that is not opened in str."
-  (declare (String str))
+(defun search-first-unopened-paranthesis (str &key ignore-literals)
+  "Returns the idx of the first paranthesis that is not opened in str.
+   If ignore-literals is set to t all mparanthesis that are within
+   \", \"\"\", ' and ''' are ignored."
+  (declare (String str)
+	   (Boolean ignore-literals))
   (let ((closed-brackets 0)
 	(result-idx nil))
     (dotimes (idx (length str))
       (let ((current-char (subseq str idx (1+ idx))))
 	(cond ((string= current-char "(")
-	       (decf closed-brackets))
+	       (when (or ignore-literals
+			 (not (in-literal-string-p str idx)))
+		 (decf closed-brackets)))
 	      ((string= current-char ")")
-	       (incf closed-brackets)
-	       (when (> closed-brackets 0)
-		 (setf result-idx idx)
-		 (setf idx (length str)))))))
+	       (when (or ignore-literals
+			 (not (in-literal-string-p str idx)))
+		 (incf closed-brackets)
+		 (when (> closed-brackets 0)
+		   (setf result-idx idx)
+		   (setf idx (length str))))))))
     result-idx))
\ No newline at end of file

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Dec 17 06:55:25 2010
@@ -1084,6 +1084,8 @@
 	 (str-2 "!BOUND(?var1) = false}")
 	 (str-3 "+?var1=-$var2}")
 	 (str-4 "!'a\"b\"c' && (+12 = - 14)}")
+	 (str-5 "!'a(+c)' && (+12 = - 14)}")
+	 (str-6 "!'abc)def'}")
 	 (result-1
 	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
 	 (result-1-1 (tm-sparql::set-unary-operators dummy-object result-1))
@@ -1097,7 +1099,15 @@
 	 (result-4
 	  (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
 	 (result-4-1
-	  (tm-sparql::set-unary-operators dummy-object result-4)))
+	  (tm-sparql::set-unary-operators dummy-object result-4))
+	 (result-5
+	  (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string))
+	 (result-5-1
+	  (tm-sparql::set-unary-operators dummy-object result-5))
+	 (result-6
+	  (getf (tm-sparql::set-boundings dummy-object str-6) :filter-string))
+	 (result-6-1
+	  (tm-sparql::set-unary-operators dummy-object result-6)))
     (is-true result-1)
     (is-true result-1-1)
     (is-true result-2)
@@ -1106,12 +1116,18 @@
     (is-true result-3-1)
     (is-true result-4)
     (is-true result-4-1)
+    (is-true result-5)
+    (is-true result-5-1)
+    (is-true result-6)
+    (is-true result-6-1)
     (is (string=
 	 result-1-1
 	 "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))"))
     (is (string= result-2-1 "(not BOUND(?var1)) = false"))
     (is (string= result-3-1 "(1+ ?var1)=(1- $var2)"))
-    (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))"))))
+    (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))"))
+    (is (string= result-5-1 "(not \"a(+c)\") && (progn (1+ 12) = (1- 14))"))
+    (is (string= result-6-1 "(not \"abc)def\")"))))
 	 
 
 (test test-set-or-and-operators
@@ -1119,20 +1135,28 @@
   (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
 	 (str-1 "isLITERAL(STR(?var))||?var = 12 && true}")
 	 (str-2 "(true != false || !false ) && 12 < 14 || !isLITERAL(?var)}")
+	 (str-3 "isLITERAL('a(bc||def') && 'abc)def'}")
 	 (result-1
 	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
-	 (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1))
+	 (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1 result-1))
 	 (result-2
 	  (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
-	 (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2)))
+	 (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2 result-2))
+	 (result-3
+	  (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
+	 (result-3-1 (tm-sparql::set-or-and-operators dummy-object result-3 result-3)))
     (is-true result-1)
     (is-true result-1-1)
     (is-true result-2)
     (is-true result-2-1)
+    (is-true result-3)
+    (is-true result-3-1)
     (is (string= (string-replace result-1-1 " " "")
 		 "(and(progn(or(prognisLITERAL(STR(?var)))(progn?var=12)))(progntrue))"))
     (is (string= (string-replace result-2-1 " " "")
-		 "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))"))))
+		 "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))"))
+    (is (string= (string-replace result-3-1 " " "")
+		 "(and(prognisLITERAL(\"a(bc||def\"))(progn\"abc)def\"))"))))
     
 
 (defun run-sparql-tests ()



From lgiessmann at common-lisp.net  Sat Dec 18 00:53:12 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 17 Dec 2010 19:53:12 -0500
Subject: [isidorus-cvs] r369 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1PTl2u-0000cf-G1@common-lisp.net>

Author: lgiessmann
Date: Fri Dec 17 19:53:11 2010
New Revision: 369

Log:
added the handling of * and / => added some unit-tests; fixed a bug with right-scope of && and || operators

Modified:
   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/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Fri Dec 17 19:53:11 2010
@@ -15,17 +15,40 @@
   "Contains all supported SPARQL-functions")
 
 
-(defparameter *supported-binary-operators*
-  (list "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/")
+(defparameter *supported-primary-arithmetic-operators*
+  (list "*" "/") "Contains all supported arithmetic operators.")
+
+
+(defparameter *supported-secundary-arithmetic-operators*
+  (list "+" "-") "Contains all supported arithmetic operators.")
+
+
+(defparameter *supported-compare-operators*
+  (list "=" "!=" "<" "<=" ">" ">=")
   "Contains all supported binary operators.")
 
 
+(defparameter *supported-join-operators*
+  (list "||" "&&") "Contains all supported join operators.")
+
+
 (defparameter *supported-unary-operators*
   (list "!" "+" "-") "Contains all supported unary operators")
 
 
+(defun *supported-arithmetic-operators* ()
+  (append *supported-primary-arithmetic-operators*
+	  *supported-secundary-arithmetic-operators*))
+
+
+(defun *supported-binary-operators* ()
+  (append (*supported-arithmetic-operators*)
+	  *supported-compare-operators*
+	  *supported-join-operators*))
+
+
 (defun *supported-operators* ()
-  (union *supported-binary-operators* *supported-unary-operators*
+  (union (*supported-binary-operators*) *supported-unary-operators*
 	 :test #'string=))
 
 
@@ -56,37 +79,146 @@
 	   (next-query (getf result-set-boundings :next-query))
 	   (filter-string-unary-ops
 	    (set-unary-operators construct filter-string))
+	   ;;TODO: encapsulate all binary operator mehtod in the method set-binary-ops
 	   (filter-string-or-and-ops
 	    (set-or-and-operators construct filter-string-unary-ops
 				  filter-string-unary-ops))
-	   (filter-string-binary-ops
-	    (set-binary-operators construct filter-string-or-and-ops))
-	    
-	   ))))
+	   (filter-string-arithmetic-ops
+	    (set-arithmetic-operators construct filter-string-or-and-ops))
+	   )
+      filter-string-arithmetic-ops)))
   ;;TODO: implement
   ;; **replace () by (progn )
   ;; **replace ', """, ''' by "
   ;; **replace !x by (not x)
-  ;; **replace +x by (1+ x)
-  ;; **replace -x by (1- x)
+  ;; **replace +x by (one+ x)
+  ;; **replace -x by (one- x)
   ;; **||, &&
-  ;; *=, !=, <, >, <=, >=, +, -, *, /
+  ;; **, /
+  ;; +, -
+  ;; *=, !=, <, >, <=, >=
   ;; *replace function(x), function(x, y), function(x, y, z)
   ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
   ;; *check if all functions that will be invoked are allowed
-  ;; *add a let with all variables that are used: every variable with $ and ? prefix
-  ;; *add a let with (true t) and (false nil)
   ;; *embrace the final result uris in <> => unit-tests
-  ;; *create and store this filter object
+  ;; *create and store this filter object => store the created string and implement
+  ;;   a method "invoke-filter(SPARQL-Triple filter-string)" so that the variables
+  ;;   are automatically contained in a letafterwards the eval function can be called
+  ;;   this method should also have a let with (true t) and (false nil)
+
+
+(defgeneric set-arithmetic-operators (construct filter-string)
+  (:documentation "Transforms the +, -, *, / operators in the filter
+                   string to the the corresponding lisp functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((filter-string-*/ (set-*-and-/-operators construct filter-string)))
+      (set-+-and---operators construct filter-string-*/))))
+
+
+(defun find-*/-operators (filter-string)
+  "Returns the idx of the first found * or / operator.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let ((first-pos (search-first-ignore-literals (list "*" "/") filter-string)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (not (string-ends-with left-part "("))
+	    first-pos
+	    (let ((next-pos
+		   (find-*/-operators (subseq filter-string (1+ first-pos)))))
+	      (when next-pos
+		(+ 1 first-pos next-pos))))))))
+
+
+(defgeneric set-*-and-/-operators (construct filter-string)
+  (:documentation "Transforms the *, / operators in the filter
+                   string to the the corresponding lisp functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((op-pos (find-*/-operators filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((op-str (subseq filter-string op-pos (1+ op-pos)))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (1+ op-pos)))
+		 (left-scope (find-*/-left-scope left-str))
+		 (right-scope (find-*/-right-scope right-str))
+		 (modified-str
+		  (concatenate
+		   'string (subseq left-str 0 (- (length left-str)
+						 (length left-scope)))
+		   "(" op-str " " left-scope " " right-scope ")"
+		   (subseq right-str (length right-scope)))))
+	    (set-*-and-/-operators construct modified-str))))))
+
+
+(defun find-*/-left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value
+	      (+ inner-value (1+ (length (name-after-paranthesis
+					  (subseq left-string inner-value))))))))
+	 (other-anchor
+	  (let ((inner-value
+		 (search-first-ignore-literals
+		  (append *supported-join-operators*
+			  *supported-secundary-arithmetic-operators*
+			  *supported-compare-operators*)
+		  left-string :from-end t)))
+	    (when inner-value
+	      (1+ 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)))))
+	 (start-idx (cond (paranthesis-pair-idx
+			   paranthesis-pair-idx)
+			  ((and first-bracket other-anchor)
+			   (max first-bracket other-anchor))
+			  ((or first-bracket other-anchor)
+			   (or first-bracket other-anchor))
+			  (t 0))))
+    (subseq left-string start-idx)))
+
+
+(defun find-*/-right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  (let* ((first-pos (search-first-ignore-literals
+		     (append *supported-join-operators*
+			     (*supported-arithmetic-operators*)
+			     *supported-compare-operators*)
+		     right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx (cond (paranthesis-pair-idx
+			 paranthesis-pair-idx)
+			((and first-pos first-bracket)
+			 (min first-pos first-bracket))
+			(first-pos first-pos)
+			(first-bracket first-bracket)
+			(t (if (= (length right-string) 0)
+			       (1- (length right-string)))))))
+    (subseq right-string 0 end-idx)))
 
 
-(defgeneric set-binary-operators (construct filter-string)
-  (:documentation "Transforms the =, !=, <, >, <=, >=, +, -, *, / operators
-                   in the filter string to the the lisp =, /=, <, >, <=, >=,
-                   +, -, * and / functions.")
+(defgeneric set-+-and---operators (construct filter-string)
+  (:documentation "Transforms the +, - operators in the filter
+                   string to the the corresponding lisp functions.")
   (:method ((construct SPARQL-Query) (filter-string String))
     ;TODO: implement
-    ))
+    filter-string))
 
 
 (defgeneric set-or-and-operators (construct filter-string original-filter-string)
@@ -94,7 +226,8 @@
                    the the lisp or and and functions.")
   (:method ((construct SPARQL-Query) (filter-string String)
 	    (original-filter-string String))
-    (let ((op-pos (search-first-ignore-literals (list "||" "&&") filter-string)))
+    (let ((op-pos (search-first-ignore-literals
+		   *supported-join-operators* filter-string)))
       (if (not op-pos)
 	  filter-string
 	  (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos)))
@@ -122,7 +255,7 @@
 	  (remove-null (map 'list #'(lambda(op-string)
 				      (when (= (length op-string) 2)
 					op-string))
-			    *supported-binary-operators*)))
+			    (*supported-binary-operators*))))
 	 (operator-str (subseq filter-string idx)))
     (if (string-starts-with-one-of operator-str 2-ops)
 	(subseq operator-str 0 2)
@@ -169,22 +302,43 @@
 (defun find-or-and-right-scope (right-string)
   "Returns the string that is the right part of the binary scope."
   (declare (String right-string))
-  (let* ((first-pos (search-first-ignore-literals (list "||" "&&") right-string))
+  (let* ((first-pos (search-first-ignore-literals
+		     *supported-join-operators* right-string))
 	 (first-bracket
 	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
 	    (when inner-value (1+ inner-value))))
-	 (end-idx (cond ((and first-pos first-bracket)
-			 (min first-pos first-bracket))
-			(first-pos first-pos)
-			(first-bracket first-bracket)
-			(t (if (= (length right-string) 0)
-			       (1- (length right-string)))))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx
+	  (cond ((and first-pos first-bracket)
+		 (if (< first-pos first-bracket)
+		     (if paranthesis-pair-idx
+			 (if (< first-pos paranthesis-pair-idx)
+			     paranthesis-pair-idx
+			     first-pos)
+			 first-pos)
+		     first-bracket))
+		(first-bracket first-bracket)
+		(first-pos
+		 (if paranthesis-pair-idx
+		     (if (< first-pos paranthesis-pair-idx)
+			 paranthesis-pair-idx
+			 first-pos)
+		     first-pos))
+		(t
+		 (if (= (length right-string) 0)
+		     0
+		     (length right-string))))))
     (subseq right-string 0 end-idx)))
 
 
 (defgeneric set-unary-operators (construct filter-string)
   (:documentation "Transforms the unary operators !, +, - to (not ),
-                   (1+ ) and (1- ). The return value is a modified filter
+                   (one+ ) and (one- ). The return value is a modified filter
                    string.")
   (:method ((construct SPARQL-Query) (filter-string String))
     (let ((result-string ""))
@@ -210,7 +364,7 @@
 			   (string-ends-with-one-of string-before
 						    (*supported-operators*)))
 		       (let ((result (unary-operator-scope filter-string idx)))
-			 (push-string (concatenate 'string "(1" current-char " ")
+			 (push-string (concatenate 'string "(one" current-char " ")
 				      result-string)
 			 (push-string (set-unary-operators construct
 							   (getf result :scope))
@@ -317,6 +471,29 @@
 	  str))))
 
 
+(defun reverse-bracket-scope (str &key (open-bracket "(") (close-bracket ")"))
+  "If str ends with close-bracket there will be returned the substring until
+   the matching open-bracket is found. Otherwise the return value is nil."
+  (declare (String str open-bracket close-bracket))
+  (when (string-ends-with str close-bracket)
+    (let ((local-str (subseq str 0 (1- (length str))))
+	  (result ")")
+	  (close-brackets 1))
+      (do ((idx (1- (length local-str)))) ((< idx 0))
+	(let ((current-char (subseq local-str idx (1+ idx))))
+	  (push-string current-char result)
+	  (cond ((string= current-char open-bracket)
+		 (when (not (in-literal-string-p local-str idx))
+		   (decf close-brackets))
+		 (when (= close-brackets 0)
+		   (setf idx 0)))
+		((string= current-char close-bracket)
+		 (when (not (in-literal-string-p local-str idx))
+		   (incf close-brackets)))))
+	(decf idx))
+      (reverse result))))
+
+
 (defun bracket-scope (str &key (open-bracket "(") (close-bracket ")"))
   "If str starts with open-bracket there will be returned the substring until
    the matching close-bracket is found. Otherwise the return value is nil."

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Fri Dec 17 19:53:11 2010
@@ -321,19 +321,48 @@
 					   quotation))))))))
 
 
-(defun search-first-ignore-literals (search-strings main-string)
+;(defun search-first-ignore-literals (search-strings main-string)
+;  (declare (String main-string)
+;	   (List search-strings))
+;  (let ((first-pos (search-first search-strings main-string)))
+;    (when first-pos
+;      (if (not (in-literal-string-p main-string first-pos))
+;	  first-pos
+;	  (let* ((literal-start (search-first (list "\"" "'") main-string))
+;		 (sub-str (subseq main-string literal-start))
+;		 (literal-result (get-literal sub-str))
+;		 (next-str (getf literal-result :next-string)))
+;	    (let ((next-pos
+;		   (search-first-ignore-literals search-strings next-str)))
+;	      (when next-pos
+;		(+ (- (length main-string) (length next-str)) next-pos))))))))
+
+
+(defun search-first-ignore-literals (search-strings main-string &key from-end)
   (declare (String main-string)
-	   (List search-strings))
-  (let ((first-pos (search-first search-strings main-string)))
+	   (List search-strings)
+	   (Boolean from-end))
+  (let ((first-pos
+	 (search-first search-strings main-string :from-end from-end)))
     (when first-pos
       (if (not (in-literal-string-p main-string first-pos))
 	  first-pos
-	  (let* ((literal-start (search-first (list "\"" "'") main-string))
-		 (sub-str (subseq main-string literal-start))
-		 (literal-result (get-literal sub-str))
-		 (next-str (getf literal-result :next-string)))
+	  (let* ((literal-start
+		  (search-first (list "\"" "'") (subseq main-string 0 first-pos)
+				:from-end from-end))
+		 (next-str
+		  (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)))))
 	    (let ((next-pos
-		   (search-first-ignore-literals search-strings next-str)))
+		   (search-first-ignore-literals search-strings next-str
+						 :from-end from-end)))
 	      (when next-pos
 		(+ (- (length main-string) (length next-str)) next-pos))))))))
 
@@ -417,7 +446,7 @@
 		      (next-idx
 		       (when l-result
 			 (- (length filter-string)
-			    (length (getf l-result :next-query))))))
+			    (length (getf l-result :next-string))))))
 		 (when (and next-idx (< pos next-idx))
 		   (setf result t)
 		   (setf idx (length filter-string)))
@@ -468,7 +497,8 @@
 	(cond ((string= current-char "(")
 	       (when (or ignore-literals
 			 (not (in-literal-string-p str idx)))
-		 (decf closed-brackets)))
+		 (decf closed-brackets)
+		 (setf result-idx nil)))
 	      ((string= current-char ")")
 	       (when (or ignore-literals
 			 (not (in-literal-string-p str idx)))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Dec 17 19:53:11 2010
@@ -33,7 +33,8 @@
 	   :test-result
 	   :test-set-boundings
 	   :test-set-unary-operators
-	   :test-set-or-and-operators))
+	   :test-set-or-and-operators
+	   :test-set-*-and-/-operators))
 
 
 (in-package :sparql-test)
@@ -1122,20 +1123,22 @@
     (is-true result-6-1)
     (is (string=
 	 result-1-1
-	 "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))"))
+	 "BOUND(?var1)||(progn (not (progn (one+ (progn (one- (progn ?var1)))))))"))
     (is (string= result-2-1 "(not BOUND(?var1)) = false"))
-    (is (string= result-3-1 "(1+ ?var1)=(1- $var2)"))
-    (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))"))
-    (is (string= result-5-1 "(not \"a(+c)\") && (progn (1+ 12) = (1- 14))"))
+    (is (string= result-3-1 "(one+ ?var1)=(one- $var2)"))
+    (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (one+ 12) = (one- 14))"))
+    (is (string= result-5-1 "(not \"a(+c)\") && (progn (one+ 12) = (one- 14))"))
     (is (string= result-6-1 "(not \"abc)def\")"))))
 	 
 
 (test test-set-or-and-operators
-  "Tests various cases of the function set-unary-operators."
+  "Tests various cases of the function set-or-and-operators."
   (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
 	 (str-1 "isLITERAL(STR(?var))||?var = 12 && true}")
 	 (str-2 "(true != false || !false ) && 12 < 14 || !isLITERAL(?var)}")
 	 (str-3 "isLITERAL('a(bc||def') && 'abc)def'}")
+	 (str-4 "(a && (b || c))}")
+	 (str-5 "(b || c) && a}")
 	 (result-1
 	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
 	 (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1 result-1))
@@ -1144,19 +1147,91 @@
 	 (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2 result-2))
 	 (result-3
 	  (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
-	 (result-3-1 (tm-sparql::set-or-and-operators dummy-object result-3 result-3)))
+	 (result-3-1 (tm-sparql::set-or-and-operators dummy-object result-3 result-3))
+	 (result-4
+	  (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
+	 (result-4-1 (tm-sparql::set-or-and-operators dummy-object result-4 result-4))
+	 (result-5
+	  (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string))
+	 (result-5-1 (tm-sparql::set-or-and-operators dummy-object result-5 result-5)))
     (is-true result-1)
     (is-true result-1-1)
     (is-true result-2)
     (is-true result-2-1)
     (is-true result-3)
     (is-true result-3-1)
+    (is-true result-4)
+    (is-true result-4-1)
+    (is-true result-5)
+    (is-true result-5-1)
     (is (string= (string-replace result-1-1 " " "")
 		 "(and(progn(or(prognisLITERAL(STR(?var)))(progn?var=12)))(progntrue))"))
     (is (string= (string-replace result-2-1 " " "")
 		 "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))"))
     (is (string= (string-replace result-3-1 " " "")
-		 "(and(prognisLITERAL(\"a(bc||def\"))(progn\"abc)def\"))"))))
+		 "(and(prognisLITERAL(\"a(bc||def\"))(progn\"abc)def\"))"))
+    (is (string= (string-replace result-4-1 " " "")
+		"(progn(and(progna)(progn(progn(or(prognb)(prognc))))))"))
+    (is (string= (string-replace result-5-1 " " "")
+		 "(and(progn(progn(or(prognb)(prognc))))(progna))"))))
+
+
+(test test-set-*-and-/-operators
+  "Tests various cases of the function set-*-and-/-operators."
+  (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
+	 (str-1 "x = a + b * c && y = a / 3 + b * 2 || 0 = 12 - 14 + 2 * 3 / 3}")
+	 (str-2 "x = 2 && (2 + 2) * 2 + 12 * 4 / 2 - 10 + 2 * (12 - 3) + (12 * 3)}")
+	 (str-3 "(x < a || ( a = 4 && 4 = x / y + (+1)) && -1)}")
+	 (str-4 "isLITERAL(((1 + '(13+4*5))') * 3) / 4) && (12 = 13 + 14 * 15 || 2 * 3 = 1)}")
+	 (result-1
+	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+	 (result-1-1
+	  (tm-sparql::set-unary-operators dummy-object result-1))
+	 (result-1-2
+	  (tm-sparql::set-or-and-operators dummy-object result-1-1 result-1))
+	 (result-1-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-1-2))
+	 (result-2
+	  (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+	 (result-2-1
+	  (tm-sparql::set-unary-operators dummy-object result-2))
+	 (result-2-2
+	  (tm-sparql::set-or-and-operators dummy-object result-2-1 result-2))
+	 (result-2-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-2-2))
+	 (result-3
+	  (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
+	 (result-3-1
+	  (tm-sparql::set-unary-operators dummy-object result-3))
+	 (result-3-2
+	  (tm-sparql::set-or-and-operators dummy-object result-3-1 result-3))
+	 (result-3-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-3-2))
+	 (result-4
+	  (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
+	 (result-4-1
+	  (tm-sparql::set-unary-operators dummy-object result-4))
+	 (result-4-2
+	  (tm-sparql::set-or-and-operators dummy-object result-4-1 result-4))
+	 (result-4-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-4-2)))
+    (is-true result-1) (is-true result-1-1)
+    (is-true result-1-2) (is-true result-1-3)
+    (is-true result-2) (is-true result-2-1)
+    (is-true result-2-2) (is-true result-2-3)
+    (is-true result-3) (is-true result-3-1)
+    (is-true result-3-2) (is-true result-3-3)
+    (is-true result-4) (is-true result-4-1)
+    (is-true result-4-2) (is-true result-4-3)
+    (is (string= (string-replace result-1-3 " " "")
+		 "(or(progn(and(prognx=a+(*bc))(progny=(/a3)+(*b2))))(progn0=12-14+(/(*23)3)))"))
+    (is (string= (string-replace result-2-3 " " "")
+		 "(and(prognx=2)(progn(*(progn2+2)2)+(/(*124)2)-10+(*2(progn12-3))+(progn(*123))))"))
+    (is (string= (string-replace result-3-3 " " "")
+		 "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(/xy)+(progn(one+1))))))))(progn(one-1))))"))
+    (is (string= (string-replace result-4-3 " " "")
+		 "(and(prognisLITERAL((/(progn(*(progn1+\"(13+4*5))\")3))4)))(progn(progn(or(progn12=13+(*1415))(progn(*23)=1)))))"))))
+	 
     
 
 (defun run-sparql-tests ()



From lgiessmann at common-lisp.net  Sat Dec 18 03:30:41 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 17 Dec 2010 22:30:41 -0500
Subject: [isidorus-cvs] r370 - trunk/src/TM-SPARQL
Message-ID: <E1PTnVJ-00062w-GQ@common-lisp.net>

Author: lgiessmann
Date: Fri Dec 17 22:30:41 2010
New Revision: 370

Log:
TM-SPARQL: added the handling of the binary + and - operators

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Fri Dec 17 22:30:41 2010
@@ -119,7 +119,9 @@
   "Returns the idx of the first found * or / operator.
    It must not be in a literal string or directly after a (."
   (declare (String filter-string))
-  (let ((first-pos (search-first-ignore-literals (list "*" "/") filter-string)))
+  (let ((first-pos
+	 (search-first-ignore-literals *supported-primary-arithmetic-operators*
+				       filter-string)))
     (when first-pos
       (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
 	(if (not (string-ends-with left-part "("))
@@ -162,8 +164,7 @@
 	 (other-anchor
 	  (let ((inner-value
 		 (search-first-ignore-literals
-		  (append *supported-join-operators*
-			  *supported-secundary-arithmetic-operators*
+		  (append *supported-secundary-arithmetic-operators*
 			  *supported-compare-operators*)
 		  left-string :from-end t)))
 	    (when inner-value
@@ -189,8 +190,7 @@
   "Returns the string that is the right part of the binary scope."
   (declare (String right-string))
   (let* ((first-pos (search-first-ignore-literals
-		     (append *supported-join-operators*
-			     (*supported-arithmetic-operators*)
+		     (append (*supported-arithmetic-operators*)
 			     *supported-compare-operators*)
 		     right-string))
 	 (first-bracket
@@ -217,8 +217,104 @@
   (:documentation "Transforms the +, - operators in the filter
                    string to the the corresponding lisp functions.")
   (:method ((construct SPARQL-Query) (filter-string String))
-    ;TODO: implement
-    filter-string))
+    (let ((op-pos (find-+--operators filter-string)))
+      (if (or (not op-pos) (= *tmp* 5))
+	    filter-string
+	  (let* ((op-str (subseq filter-string op-pos (1+ op-pos)))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (1+ op-pos)))
+		 (left-scope (find-+--left-scope left-str))
+		 (right-scope (find-+--right-scope right-str))
+		 (modified-str
+		  (concatenate
+		   'string (subseq left-str 0 (- (length left-str)
+						 (length left-scope)))
+		   "(" op-str " " left-scope " " right-scope ")"
+		   (subseq right-str (length right-scope)))))
+	    ;(format t "fs:_~a_~%os:_~a_~%ls:_~a_~%lc:_~a_~%rs:_~a_~%rc:_~a_~%ms:_~a_~%~%"
+	    ;filter-string op-str left-str left-scope right-str right-scope
+	    ;modified-str)
+	    (set-+-and---operators construct modified-str))))))
+
+
+(defun find-+--left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  ;TODO: adapt
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value
+	      (+ inner-value (1+ (length (name-after-paranthesis
+					  (subseq left-string inner-value))))))))
+	 (other-anchor
+	  (let ((inner-value
+		 (search-first-ignore-literals
+		  (append *supported-secundary-arithmetic-operators*
+			  *supported-compare-operators*)
+		  left-string :from-end t)))
+	    (when inner-value
+	      (1+ 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)))))
+	 (start-idx (cond (paranthesis-pair-idx
+			   paranthesis-pair-idx)
+			  ((and first-bracket other-anchor)
+			   (max first-bracket other-anchor))
+			  ((or first-bracket other-anchor)
+			   (or first-bracket other-anchor))
+			  (t 0))))
+    (subseq left-string start-idx)))
+
+
+(defun find-+--right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  ;TODO: adapt
+  (let* ((first-pos (search-first-ignore-literals
+		     (append (*supported-arithmetic-operators*)
+			     *supported-compare-operators*)
+		     right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx (cond (paranthesis-pair-idx
+			 paranthesis-pair-idx)
+			((and first-pos first-bracket)
+			 (min first-pos first-bracket))
+			(first-pos first-pos)
+			(first-bracket first-bracket)
+			(t (if (= (length right-string) 0)
+			       (1- (length right-string)))))))
+    (subseq right-string 0 end-idx)))
+
+
+(defun find-+--operators (filter-string)
+  "Returns the idx of the first found + or - operator.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let ((first-pos
+	 (search-first-ignore-literals *supported-secundary-arithmetic-operators*
+				       filter-string)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (and (not (string-ends-with left-part "(one"))
+		 (not (string-ends-with left-part "(")))
+	    first-pos
+	    (let ((next-pos
+		   (find-+--operators (subseq filter-string (1+ first-pos)))))
+	      (when next-pos
+		(+ 1 first-pos next-pos))))))))
 
 
 (defgeneric set-or-and-operators (construct filter-string original-filter-string)



From lgiessmann at common-lisp.net  Sat Dec 18 03:55:28 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 17 Dec 2010 22:55:28 -0500
Subject: [isidorus-cvs] r371 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1PTntI-0007DH-AM@common-lisp.net>

Author: lgiessmann
Date: Fri Dec 17 22:55:28 2010
New Revision: 371

Log:
TM-SPARQL: added some unit-tests for the binary + and - operators

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Fri Dec 17 22:55:28 2010
@@ -95,7 +95,7 @@
   ;; **replace -x by (one- x)
   ;; **||, &&
   ;; **, /
-  ;; +, -
+  ;; *+, -
   ;; *=, !=, <, >, <=, >=
   ;; *replace function(x), function(x, y), function(x, y, z)
   ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
@@ -231,9 +231,6 @@
 						 (length left-scope)))
 		   "(" op-str " " left-scope " " right-scope ")"
 		   (subseq right-str (length right-scope)))))
-	    ;(format t "fs:_~a_~%os:_~a_~%ls:_~a_~%lc:_~a_~%rs:_~a_~%rc:_~a_~%ms:_~a_~%~%"
-	    ;filter-string op-str left-str left-scope right-str right-scope
-	    ;modified-str)
 	    (set-+-and---operators construct modified-str))))))
 
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Dec 17 22:55:28 2010
@@ -34,7 +34,8 @@
 	   :test-set-boundings
 	   :test-set-unary-operators
 	   :test-set-or-and-operators
-	   :test-set-*-and-/-operators))
+	   :test-set-*-and-/-operators
+	   :test-set-+-and---operators))
 
 
 (in-package :sparql-test)
@@ -1231,6 +1232,89 @@
 		 "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(/xy)+(progn(one+1))))))))(progn(one-1))))"))
     (is (string= (string-replace result-4-3 " " "")
 		 "(and(prognisLITERAL((/(progn(*(progn1+\"(13+4*5))\")3))4)))(progn(progn(or(progn12=13+(*1415))(progn(*23)=1)))))"))))
+
+
+(test test-set-+-and---operators
+  "Tests various cases of the function set-*-and-/-operators."
+  (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
+	 (str-1 "x = a + b * c && y = a / 3 + b * 2 || 0 = 12 - 14 + 2 * 3 / 3}")
+	 (str-2 "x = 2 && (2 + 2) * 2 + 12 * 4 / 2 - 10 + 2 * (12 - 3) + (12 * 3)}")
+	 (str-3 "(x < a || ( a = 4 && 4 = x / y + (+1)) && -1)}")
+	 (str-4 "isLITERAL(((1 + '(13+4*5))') * 3) / 4) && (12 = 13 + 14 * 15 || 2 * 3 = 1)}")
+	 (str-5 "(1 + 2 >= 3) || ((2 - 4) + 5 + 6) = 3}")
+	 (result-1
+	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+	 (result-1-1
+	  (tm-sparql::set-unary-operators dummy-object result-1))
+	 (result-1-2
+	  (tm-sparql::set-or-and-operators dummy-object result-1-1 result-1))
+	 (result-1-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-1-2))
+	 (result-1-4
+	  (tm-sparql::set-+-and---operators dummy-object result-1-3))
+	 (result-2
+	  (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+	 (result-2-1
+	  (tm-sparql::set-unary-operators dummy-object result-2))
+	 (result-2-2
+	  (tm-sparql::set-or-and-operators dummy-object result-2-1 result-2))
+	 (result-2-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-2-2))
+	 (result-2-4
+	  (tm-sparql::set-+-and---operators dummy-object result-2-3))
+	 (result-3
+	  (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
+	 (result-3-1
+	  (tm-sparql::set-unary-operators dummy-object result-3))
+	 (result-3-2
+	  (tm-sparql::set-or-and-operators dummy-object result-3-1 result-3))
+	 (result-3-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-3-2))
+	 (result-3-4
+	  (tm-sparql::set-+-and---operators dummy-object result-3-3))
+	 (result-4
+	  (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
+	 (result-4-1
+	  (tm-sparql::set-unary-operators dummy-object result-4))
+	 (result-4-2
+	  (tm-sparql::set-or-and-operators dummy-object result-4-1 result-4))
+	 (result-4-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-4-2))
+	 (result-4-4
+	  (tm-sparql::set-+-and---operators dummy-object result-4-3))
+	 (result-5
+	  (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string))
+	 (result-5-1
+	  (tm-sparql::set-unary-operators dummy-object result-5))
+	 (result-5-2
+	  (tm-sparql::set-or-and-operators dummy-object result-5-1 result-5))
+	 (result-5-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-5-2))
+	 (result-5-4
+	  (tm-sparql::set-+-and---operators dummy-object result-5-3)))
+    (is-true result-1) (is-true result-1-1)
+    (is-true result-1-2) (is-true result-1-3)
+    (is-true result-2) (is-true result-2-1)
+    (is-true result-2-2) (is-true result-2-3)
+    (is-true result-3) (is-true result-3-1)
+    (is-true result-3-2) (is-true result-3-3)
+    (is-true result-4) (is-true result-4-1)
+    (is-true result-4-2) (is-true result-4-3)
+    (is-true result-1-4) (is-true result-2-4)
+    (is-true result-3-4) (is-true result-4-4)
+    (is-true result-5) (is-true result-5-1)
+    (is-true result-5-2) (is-true result-5-3)
+    (is-true result-5-4)
+    (is (string= (string-replace result-1-4 " " "")
+		 "(or(progn(and(prognx=(+a(*bc)))(progny=(+(/a3)(*b2)))))(progn0=(+(-1214)(/(*23)3))))"))
+    (is (string= (string-replace result-2-4 " " "")
+		 "(and(prognx=2)(progn(+(+(-(+(*(progn(+22))2)(/(*124)2))10)(*2(progn(-123))))(progn(*123)))))"))
+    (is (string= (string-replace result-3-4 " " "")
+		 "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(+(/xy)(progn(one+1)))))))))(progn(one-1))))"))
+    (is (string= (string-replace result-4-4 " " "")
+		 "(and(prognisLITERAL((/(progn(*(progn(+1\"(13+4*5))\"))3))4)))(progn(progn(or(progn12=(+13(*1415)))(progn(*23)=1)))))"))
+    (is (string= (string-replace result-5-4 " " "")
+		 "(or(progn(progn(+12)>=3))(progn(progn(+(+(progn(-24))5)6))=3))"))))
 	 
     
 



From lgiessmann at common-lisp.net  Sat Dec 18 05:22:09 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 18 Dec 2010 00:22:09 -0500
Subject: [isidorus-cvs] r372 - trunk/src/TM-SPARQL
Message-ID: <E1PTpFB-000642-Mx@common-lisp.net>

Author: lgiessmann
Date: Sat Dec 18 00:22:09 2010
New Revision: 372

Log:
TM-SPARQL: added the handling of the >, <, >=, <=, = and != operators

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Sat Dec 18 00:22:09 2010
@@ -24,7 +24,7 @@
 
 
 (defparameter *supported-compare-operators*
-  (list "=" "!=" "<" "<=" ">" ">=")
+  (list "!=" "<=" ">=" "=" "<" ">") ;not the order is important!
   "Contains all supported binary operators.")
 
 
@@ -36,6 +36,22 @@
   (list "!" "+" "-") "Contains all supported unary operators")
 
 
+(defun *2-compare-operators* ()
+  (remove-null
+   (map 'list #'(lambda(op)
+		  (when (= (length op) 2)
+		    op))
+	*supported-compare-operators*)))
+
+
+(defun *1-compare-operators* ()
+  (remove-null
+   (map 'list #'(lambda(op)
+		  (when (= (length op) 1)
+		    op))
+	*supported-compare-operators*)))
+
+
 (defun *supported-arithmetic-operators* ()
   (append *supported-primary-arithmetic-operators*
 	  *supported-secundary-arithmetic-operators*))
@@ -74,19 +90,20 @@
   (:documentation "A helper functions that returns a filter and the next-query
                    string in the form (:next-query string :filter object).")
   (:method ((construct SPARQL-Query) (query-string String))
+    ;note the order of the invacations is important!
     (let* ((result-set-boundings (set-boundings construct query-string))
 	   (filter-string (getf result-set-boundings :filter-string))
 	   (next-query (getf result-set-boundings :next-query))
 	   (filter-string-unary-ops
 	    (set-unary-operators construct filter-string))
-	   ;;TODO: encapsulate all binary operator mehtod in the method set-binary-ops
 	   (filter-string-or-and-ops
 	    (set-or-and-operators construct filter-string-unary-ops
 				  filter-string-unary-ops))
 	   (filter-string-arithmetic-ops
 	    (set-arithmetic-operators construct filter-string-or-and-ops))
-	   )
-      filter-string-arithmetic-ops)))
+	   (filter-string-compare-ops
+	    (set-compare-operators construct filter-string-arithmetic-ops)))
+      filter-string-compare-ops)))
   ;;TODO: implement
   ;; **replace () by (progn )
   ;; **replace ', """, ''' by "
@@ -95,8 +112,8 @@
   ;; **replace -x by (one- x)
   ;; **||, &&
   ;; **, /
-  ;; *+, -
-  ;; *=, !=, <, >, <=, >=
+  ;; **+, -
+  ;; **=, !=, <, >, <=, >=
   ;; *replace function(x), function(x, y), function(x, y, z)
   ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
   ;; *check if all functions that will be invoked are allowed
@@ -107,6 +124,106 @@
   ;;   this method should also have a let with (true t) and (false nil)
 
 
+(defvar *tmp* 0)
+(defgeneric set-compare-operators (construct filter-string)
+  (:documentation "Transforms the =, !=, <, >, <= and >= operators in the
+                   filter string to the the corresponding lisp functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (incf *tmp*)
+    (let ((op-pos (find-compare-operators filter-string)))
+      (if (or (not op-pos) (= *tmp* 5))
+	  (progn
+	    (setf *tmp* 0)
+	    filter-string)
+	  (let* ((op-str (if (string-starts-with-one-of
+			      (subseq filter-string op-pos)
+			      (*2-compare-operators*))
+			     (subseq filter-string op-pos (+ 2 op-pos))
+			     (subseq filter-string op-pos (1+ op-pos))))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (+ (length op-str) op-pos)))
+		 (left-scope (find-compare-left-scope left-str))
+		 (right-scope (find-compare-right-scope right-str))
+		 (modified-str
+		  (concatenate
+		   'string (subseq left-str 0 (- (length left-str)
+						 (length left-scope)))
+		   "(" op-str " " left-scope " " right-scope ")"
+		   (subseq right-str (length right-scope)))))
+	    (set-compare-operators construct modified-str))))))
+
+
+(defun find-compare-operators (filter-string)
+  "Returns the idx of the first found =, !=, <, >, <= or >= operator.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let* ((first-pos
+	  (search-first-ignore-literals *supported-compare-operators*
+					filter-string))
+	 (delta (if first-pos
+		    (if (string-starts-with-one-of
+			 (subseq filter-string first-pos)
+			 (*2-compare-operators*))
+			2
+			1)
+		    1)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (not (string-ends-with-one-of
+		  left-part (append (*1-compare-operators*) (list "("))))
+	    first-pos
+	    (let ((next-pos
+		   (find-compare-operators (subseq filter-string (+ delta first-pos)))))
+	      (when next-pos
+		(+ delta first-pos next-pos))))))))
+
+
+(defun find-compare-left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value
+	      (+ 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)))))
+	 (start-idx (or first-bracket paranthesis-pair-idx 0)))
+    (subseq left-string start-idx)))
+
+
+(defun find-compare-right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  (let* ((first-pos
+	  (search-first-ignore-literals *supported-compare-operators*
+					right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx (cond (paranthesis-pair-idx
+			 paranthesis-pair-idx)
+			((and first-pos first-bracket)
+			 (min first-pos first-bracket))
+			(first-pos first-pos)
+			(first-bracket first-bracket)
+			(t (if (= (length right-string) 0)
+			       0
+			       (length right-string))))))
+    (subseq right-string 0 end-idx)))
+
+
 (defgeneric set-arithmetic-operators (construct filter-string)
   (:documentation "Transforms the +, -, *, / operators in the filter
                    string to the the corresponding lisp functions.")
@@ -237,7 +354,6 @@
 (defun find-+--left-scope (left-string)
   "Returns the string that is the left part of the binary scope."
   (declare (String left-string))
-  ;TODO: adapt
   (let* ((first-bracket
 	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
 	    (when inner-value
@@ -245,10 +361,8 @@
 					  (subseq left-string inner-value))))))))
 	 (other-anchor
 	  (let ((inner-value
-		 (search-first-ignore-literals
-		  (append *supported-secundary-arithmetic-operators*
-			  *supported-compare-operators*)
-		  left-string :from-end t)))
+		 (search-first-ignore-literals *supported-compare-operators*
+					       left-string :from-end t)))
 	    (when inner-value
 	      (1+ inner-value))))
 	 (paranthesis-pair-idx
@@ -271,7 +385,6 @@
 (defun find-+--right-scope (right-string)
   "Returns the string that is the right part of the binary scope."
   (declare (String right-string))
-  ;TODO: adapt
   (let* ((first-pos (search-first-ignore-literals
 		     (append (*supported-arithmetic-operators*)
 			     *supported-compare-operators*)



From lgiessmann at common-lisp.net  Sat Dec 18 05:43:44 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 18 Dec 2010 00:43:44 -0500
Subject: [isidorus-cvs] r373 - trunk/src/unit_tests
Message-ID: <E1PTpa4-0007E1-30@common-lisp.net>

Author: lgiessmann
Date: Sat Dec 18 00:43:43 2010
New Revision: 373

Log:
TM-SPARQL: added unit-tests for all compare-operators

Modified:
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Sat Dec 18 00:43:43 2010
@@ -35,7 +35,8 @@
 	   :test-set-unary-operators
 	   :test-set-or-and-operators
 	   :test-set-*-and-/-operators
-	   :test-set-+-and---operators))
+	   :test-set-+-and---operators
+	   :test-set-compare-operators))
 
 
 (in-package :sparql-test)
@@ -1315,6 +1316,119 @@
 		 "(and(prognisLITERAL((/(progn(*(progn(+1\"(13+4*5))\"))3))4)))(progn(progn(or(progn12=(+13(*1415)))(progn(*23)=1)))))"))
     (is (string= (string-replace result-5-4 " " "")
 		 "(or(progn(progn(+12)>=3))(progn(progn(+(+(progn(-24))5)6))=3))"))))
+
+
+(test test-set-compare-operators
+  "Tests various cases of the function set-*-and-/-operators."
+  (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
+	 (str-1 "x = a + b * c && y = a / 3 + b * 2 || 0 = 12 - 14 + 2 * 3 / 3}")
+	 (str-2 "x = 2 && (2 + 2) * 2 + 12 * 4 / 2 - 10 + 2 * (12 - 3) + (12 * 3)}")
+	 (str-3 "(x < a || ( a = 4 && 4 = x / y + (+1)) && -1)}")
+	 (str-4 "isLITERAL(((1 + '(13+4*5))') * 3) / 4) && (12 = 13 + 14 * 15 || 2 * 3 = 1)}")
+	 (str-5 "(1 + 2 >= 3) || ((2 - 4) + 5 + 6) = 3}")
+	 (str-6 "2 > 1 <= 0 != 99 || true}")
+	 (result-1
+	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+	 (result-1-1
+	  (tm-sparql::set-unary-operators dummy-object result-1))
+	 (result-1-2
+	  (tm-sparql::set-or-and-operators dummy-object result-1-1 result-1))
+	 (result-1-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-1-2))
+	 (result-1-4
+	  (tm-sparql::set-+-and---operators dummy-object result-1-3))
+	 (result-1-5
+	  (tm-sparql::set-compare-operators dummy-object result-1-4))
+	 (result-2
+	  (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+	 (result-2-1
+	  (tm-sparql::set-unary-operators dummy-object result-2))
+	 (result-2-2
+	  (tm-sparql::set-or-and-operators dummy-object result-2-1 result-2))
+	 (result-2-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-2-2))
+	 (result-2-4
+	  (tm-sparql::set-+-and---operators dummy-object result-2-3))
+	 (result-2-5
+	  (tm-sparql::set-compare-operators dummy-object result-2-4))
+	 (result-3
+	  (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
+	 (result-3-1
+	  (tm-sparql::set-unary-operators dummy-object result-3))
+	 (result-3-2
+	  (tm-sparql::set-or-and-operators dummy-object result-3-1 result-3))
+	 (result-3-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-3-2))
+	 (result-3-4
+	  (tm-sparql::set-+-and---operators dummy-object result-3-3))
+	 (result-3-5
+	  (tm-sparql::set-compare-operators dummy-object result-3-4))
+	 (result-4
+	  (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
+	 (result-4-1
+	  (tm-sparql::set-unary-operators dummy-object result-4))
+	 (result-4-2
+	  (tm-sparql::set-or-and-operators dummy-object result-4-1 result-4))
+	 (result-4-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-4-2))
+	 (result-4-4
+	  (tm-sparql::set-+-and---operators dummy-object result-4-3))
+	 (result-4-5
+	  (tm-sparql::set-compare-operators dummy-object result-4-4))
+	 (result-5
+	  (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string))
+	 (result-5-1
+	  (tm-sparql::set-unary-operators dummy-object result-5))
+	 (result-5-2
+	  (tm-sparql::set-or-and-operators dummy-object result-5-1 result-5))
+	 (result-5-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-5-2))
+	 (result-5-4
+	  (tm-sparql::set-+-and---operators dummy-object result-5-3))
+	 (result-5-5
+	  (tm-sparql::set-compare-operators dummy-object result-5-4))
+	 (result-6
+	  (getf (tm-sparql::set-boundings dummy-object str-6) :filter-string))
+	 (result-6-1
+	  (tm-sparql::set-unary-operators dummy-object result-6))
+	 (result-6-2
+	  (tm-sparql::set-or-and-operators dummy-object result-6-1 result-6))
+	 (result-6-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-6-2))
+	 (result-6-4
+	  (tm-sparql::set-+-and---operators dummy-object result-6-3))
+	 (result-6-5
+	  (tm-sparql::set-compare-operators dummy-object result-6-4)))
+    (is-true result-1) (is-true result-1-1)
+    (is-true result-1-2) (is-true result-1-3)
+    (is-true result-2) (is-true result-2-1)
+    (is-true result-2-2) (is-true result-2-3)
+    (is-true result-3) (is-true result-3-1)
+    (is-true result-3-2) (is-true result-3-3)
+    (is-true result-4) (is-true result-4-1)
+    (is-true result-4-2) (is-true result-4-3)
+    (is-true result-1-4) (is-true result-2-4)
+    (is-true result-3-4) (is-true result-4-4)
+    (is-true result-5) (is-true result-5-1)
+    (is-true result-5-2) (is-true result-5-3)
+    (is-true result-5-4) (is-true result-1-5)
+    (is-true result-2-5) (is-true result-3-5)
+    (is-true result-4-5) (is-true result-5-5)
+    (is-true result-6-1) (is-true result-6-2)
+    (is-true result-6-3) (is-true result-6-4)
+    (is-true result-6-5)
+    (is (string= (string-replace result-1-5 " " "")
+		 "(or(progn(and(progn(=x(+a(*bc))))(progn(=y(+(/a3)(*b2))))))(progn(=0(+(-1214)(/(*23)3)))))"))
+    (is (string= (string-replace result-2-5 " " "")
+		 "(and(progn(=x2))(progn(+(+(-(+(*(progn(+22))2)(/(*124)2))10)(*2(progn(-123))))(progn(*123)))))"))
+    (is (string= (string-replace result-3-4 " " "")
+		 "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(+(/xy)(progn(one+1)))))))))(progn(one-1))))"))
+    (is (string= (string-replace result-4-5 " " "")
+		 "(and(prognisLITERAL((/(progn(*(progn(+1\"(13+4*5))\"))3))4)))(progn(progn(or(progn(=12(+13(*1415))))(progn(=(*23)1))))))"))
+    (is (string= (string-replace result-5-5 " " "")
+		 "(or(progn(progn(>=(+12)3)))(progn(=(progn(+(+(progn(-24))5)6))3)))"))
+    (is (string= (string-replace result-6-5 " " "")
+		 "(or(progn(!=(<=(>21)0)99))(progntrue))"))))
 	 
     
 



From lgiessmann at common-lisp.net  Sat Dec 18 10:45:40 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sat, 18 Dec 2010 05:45:40 -0500
Subject: [isidorus-cvs] r374 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1PTuIG-0002bW-Qz@common-lisp.net>

Author: lgiessmann
Date: Sat Dec 18 05:45:40 2010
New Revision: 374

Log:
TM-SPARQL: added the handling of supported filter function => added unit-tests => fixed several bug with white space characters

Modified:
   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/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Sat Dec 18 05:45:40 2010
@@ -102,39 +102,89 @@
 	   (filter-string-arithmetic-ops
 	    (set-arithmetic-operators construct filter-string-or-and-ops))
 	   (filter-string-compare-ops
-	    (set-compare-operators construct filter-string-arithmetic-ops)))
-      filter-string-compare-ops)))
+	    (set-compare-operators construct filter-string-arithmetic-ops))
+	   (filter-string-functions
+	    (set-functions construct filter-string-compare-ops)))
+      filter-string-functions)))
   ;;TODO: implement
-  ;; **replace () by (progn )
-  ;; **replace ', """, ''' by "
-  ;; **replace !x by (not x)
-  ;; **replace +x by (one+ x)
-  ;; **replace -x by (one- x)
-  ;; **||, &&
-  ;; **, /
-  ;; **+, -
-  ;; **=, !=, <, >, <=, >=
-  ;; *replace function(x), function(x, y), function(x, y, z)
-  ;;   by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
   ;; *check if all functions that will be invoked are allowed
-  ;; *embrace the final result uris in <> => unit-tests
+  ;; *implement wrapper functions, also for the operators
+  ;;   it would be nice of the self defined operator functions would be in a
+  ;;   separate packet, e.g. filter-functions, so =, ... would couse no
+  ;;   collisions
+  ;; *embrace the final results uris in <> => unit-tests
   ;; *create and store this filter object => store the created string and implement
   ;;   a method "invoke-filter(SPARQL-Triple filter-string)" so that the variables
   ;;   are automatically contained in a letafterwards the eval function can be called
   ;;   this method should also have a let with (true t) and (false nil)
 
 
-(defvar *tmp* 0)
+(defgeneric set-functions (construct filter-string)
+  (:documentation "Transforms all supported functions of the form
+                   function(x, y) to (function x y).")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((op-pos (find-functions filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((fun-name
+		  (return-if-starts-with (subseq filter-string op-pos)
+					 *supported-functions*))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string
+				    (+ op-pos (length fun-name))))
+		 (cleaned-right-str (trim-whitespace-left right-str))
+		 (arg-list (bracket-scope cleaned-right-str))
+		 (cleaned-arg-list (clean-function-arguments arg-list))
+		 (modified-str
+		  (concatenate
+		   'string left-str "(" fun-name " " cleaned-arg-list ")"
+		   (subseq right-str (+ (- (length right-str)
+					   (length cleaned-right-str))
+					(length arg-list))))))
+	    (set-functions construct modified-str))))))
+
+
+(defun clean-function-arguments (argument-string)
+  "Transforms all arguments within an argument list of the form
+   (x, y, z, ...) to x y z."
+  (declare (String argument-string))
+  (when (and (string-starts-with argument-string "(")
+	     (string-ends-with argument-string ")"))
+    (let ((local-str (subseq argument-string 1 (1- (length argument-string))))
+	  (result ""))
+      (dotimes (idx (length local-str) result)
+	(let ((current-char (subseq local-str idx (1+ idx))))
+	  (if (and (string= current-char ",")
+		   (not (in-literal-string-p local-str idx)))
+	      (push-string " " result)
+	      (push-string current-char result)))))))
+
+
+(defun find-functions (filter-string)
+  "Returns the idx of the first found 'BOUND', 'isLITERAL', 'STR',
+   'DATATYPE', or 'REGEX'.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let* ((first-pos
+	  (search-first-ignore-literals *supported-functions*
+					filter-string)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (not (string-ends-with left-part "("))
+	    first-pos
+	    (let ((next-pos
+		   (find-functions (subseq filter-string (1+ first-pos)))))
+	      (when next-pos
+		(+ 1 first-pos next-pos))))))))
+
+
 (defgeneric set-compare-operators (construct filter-string)
   (:documentation "Transforms the =, !=, <, >, <= and >= operators in the
                    filter string to the the corresponding lisp functions.")
   (:method ((construct SPARQL-Query) (filter-string String))
-    (incf *tmp*)
     (let ((op-pos (find-compare-operators filter-string)))
-      (if (or (not op-pos) (= *tmp* 5))
-	  (progn
-	    (setf *tmp* 0)
-	    filter-string)
+      (if (not op-pos)
+	  filter-string
 	  (let* ((op-str (if (string-starts-with-one-of
 			      (subseq filter-string op-pos)
 			      (*2-compare-operators*))
@@ -335,8 +385,8 @@
                    string to the the corresponding lisp functions.")
   (:method ((construct SPARQL-Query) (filter-string String))
     (let ((op-pos (find-+--operators filter-string)))
-      (if (or (not op-pos) (= *tmp* 5))
-	    filter-string
+      (if (not op-pos)
+	  filter-string
 	  (let* ((op-str (subseq filter-string op-pos (1+ op-pos)))
 		 (left-str (subseq filter-string 0 op-pos))
 		 (right-str (subseq filter-string (1+ op-pos)))
@@ -438,7 +488,7 @@
 	  filter-string
 	  (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos)))
 		 (left-str (subseq filter-string 0 op-pos))
-		 (right-str (subseq filter-string (+ 2 op-pos)))
+		 (right-str (subseq filter-string (+ (length op-str) op-pos)))
 		 (left-scope (find-or-and-left-scope left-str))
 		 (right-scope (find-or-and-right-scope right-str))
 		 (modified-str
@@ -567,8 +617,8 @@
 			(trim-whitespace-right (subseq filter-string 0 idx))))
 		   (if (or (string= string-before "")
 			   (string-ends-with string-before "(progn")
-			   (string-ends-with-one-of string-before
-						    (*supported-operators*)))
+			   (string-ends-with-one-of
+			    string-before (append (*supported-operators*) (list "("))))
 		       (let ((result (unary-operator-scope filter-string idx)))
 			 (push-string (concatenate 'string "(one" current-char " ")
 				      result-string)
@@ -719,7 +769,7 @@
 		       (progn
 			 (setf idx (- (1- (length str))
 				      (length (getf literal :next-string))))
-			 (push-string (getf literal :literal) str))
+			 (push-string (getf literal :literal) result))
 		       (progn
 			 (setf result nil)
 			 (setf idx (length str))))))
@@ -790,7 +840,13 @@
 		   (error (make-sparql-parser-condition
 			   (subseq query-string idx)
 			   (original-query construct)
-			   "a valid filter, but the filter is not complete")))
+			   (format nil
+				   "a valid filter, but the filter is not complete, ~a"
+				   (if (> open-brackets 0)
+				       (format nil "~a ')' is missing"
+					       open-brackets)
+				       (format nil "~a '(' is missing"
+					       open-brackets))))))
 		 (setf result
 		       (list :next-query (subseq query-string idx)
 			     :filter-string filter-string)))
@@ -804,7 +860,7 @@
   represents a (progn) block."
   (declare (String query-string)
 	   (Integer idx))
-  (let* ((delimiters (append (list " " (string #\Space) (string #\Tab)
+  (let* ((delimiters (append (list " " "," (string #\Space) (string #\Tab)
 				   (string #\Newline) (string #\cr) "(" ")")
 			     (*supported-operators*)))
 	 (string-before (trim-whitespace-right (subseq query-string 0 idx)))
@@ -813,8 +869,9 @@
 	 (fragment-before
 	  (if (and (not fragment-before-idx)
 		   (and (> (length string-before) 0)
-			(not (find string-before *supported-functions*
-				   :test #'string=))))
+			(not (string-ends-with-one-of
+			      (trim-whitespace-right string-before)
+			      *supported-functions*))))
 	      (error (make-condition
 		      'SPARQL-PARSER-ERROR
 		      :message (format nil "Invalid filter: \"~a\"~%"
@@ -838,16 +895,15 @@
 	      'SPARQL-PARSER-ERROR
 	      :message (format nil "Invalid filter: found \"~a\" but expected ~a"
 			       fragment-before *supported-functions*))))
-	  (when (not (find fragment-before (append *supported-functions*
-						   delimiters)
-			   :test #'string=))
+	  (when (not (string-starts-with-one-of
+		      fragment-before (append *supported-functions* delimiters)))
 	    (error
 	     (make-condition
 	      'SPARQL-PARSER-ERROR
 	      :message
 	      (format nil "Invalid character: \"~a\", expected characters: ~a"
 		      fragment-before (append *supported-functions* delimiters)))))
-	  (if (find fragment-before *supported-functions* :test #'string=)
+	  (if (string-ends-with-one-of fragment-before *supported-functions*)
 	      nil
 	      t))
 	(if (find string-before *supported-functions* :test #'string=)

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Sat Dec 18 05:45:40 2010
@@ -40,7 +40,8 @@
 	   :in-literal-string-p
 	   :find-literal-end
 	   :get-literal-quotation
-	   :get-literal))
+	   :get-literal
+	   :return-if-starts-with))
 
 (in-package :base-tools)
 
@@ -506,4 +507,17 @@
 		 (when (> closed-brackets 0)
 		   (setf result-idx idx)
 		   (setf idx (length str))))))))
-    result-idx))
\ No newline at end of file
+    result-idx))
+
+
+(defun return-if-starts-with (str to-be-matched &key from-end ignore-case)
+  "Returns the string that is contained in to-be-matched and that is the
+   start of the string str."
+  (declare (String str)
+	   (List to-be-matched)
+	   (Boolean from-end ignore-case))
+  (loop for try in to-be-matched
+     when (if from-end
+	      (string-ends-with str try :ignore-case ignore-case)
+	      (string-starts-with str try :ignore-case ignore-case))
+     return try))
\ No newline at end of file

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Sat Dec 18 05:45:40 2010
@@ -36,7 +36,8 @@
 	   :test-set-or-and-operators
 	   :test-set-*-and-/-operators
 	   :test-set-+-and---operators
-	   :test-set-compare-operators))
+	   :test-set-compare-operators
+	   :test-set-functions))
 
 
 (in-package :sparql-test)
@@ -1236,7 +1237,7 @@
 
 
 (test test-set-+-and---operators
-  "Tests various cases of the function set-*-and-/-operators."
+  "Tests various cases of the function set-+-and---operators."
   (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
 	 (str-1 "x = a + b * c && y = a / 3 + b * 2 || 0 = 12 - 14 + 2 * 3 / 3}")
 	 (str-2 "x = 2 && (2 + 2) * 2 + 12 * 4 / 2 - 10 + 2 * (12 - 3) + (12 * 3)}")
@@ -1319,7 +1320,7 @@
 
 
 (test test-set-compare-operators
-  "Tests various cases of the function set-*-and-/-operators."
+  "Tests various cases of the function set-compare-operators."
   (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
 	 (str-1 "x = a + b * c && y = a / 3 + b * 2 || 0 = 12 - 14 + 2 * 3 / 3}")
 	 (str-2 "x = 2 && (2 + 2) * 2 + 12 * 4 / 2 - 10 + 2 * (12 - 3) + (12 * 3)}")
@@ -1429,6 +1430,104 @@
 		 "(or(progn(progn(>=(+12)3)))(progn(=(progn(+(+(progn(-24))5)6))3)))"))
     (is (string= (string-replace result-6-5 " " "")
 		 "(or(progn(!=(<=(>21)0)99))(progntrue))"))))
+
+
+(test test-set-functions
+  "Tests various cases of the function set-functions"
+  (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query "  "))
+	 (str-1 "BOUND((  (?var)  )) || (isLITERAL($var) && ?var = 'abc')}")
+	 (str-2
+	  "(REGEX(?var1, '''''', ?var3) || (?var1 > ?var3 && (STR( ?var) = \"abc\")))}")
+	 (str-3
+	  "STR(DATATYPE(?var3,isLITERAL(x, y))) || +?var1 = -?var2 + ?var2 * ?var3}")
+	 (str-4 "DATATYPE(?var3) ||isLITERAL(+?var1 = -?var2)}")
+	 (str-5 "DATATYPE(?var3) ||(isLITERAL  (+?var1 = -?var2))}")
+	 (result-1
+	  (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+	 (result-1-2
+	  (tm-sparql::set-or-and-operators dummy-object result-1 result-1))
+	 (result-1-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-1-2))
+	 (result-1-4
+	  (tm-sparql::set-+-and---operators dummy-object result-1-3))
+	 (result-1-5
+	  (tm-sparql::set-compare-operators dummy-object result-1-4))
+	 (result-1-6
+	  (tm-sparql::set-functions dummy-object result-1-5))
+	 (result-2
+	  (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+	 (result-2-2
+	  (tm-sparql::set-or-and-operators dummy-object result-2 result-2))
+	 (result-2-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-2-2))
+	 (result-2-4
+	  (tm-sparql::set-+-and---operators dummy-object result-2-3))
+	 (result-2-5
+	  (tm-sparql::set-compare-operators dummy-object result-2-4))
+	 (result-2-6
+	  (tm-sparql::set-functions dummy-object result-2-5))
+	 (result-3
+	      (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
+	 (result-3-2-1
+	  (tm-sparql::set-unary-operators dummy-object result-3))
+	 (result-3-2
+	  (tm-sparql::set-or-and-operators dummy-object result-3-2-1 result-3))
+	 (result-3-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-3-2))
+	 (result-3-4
+	  (tm-sparql::set-+-and---operators dummy-object result-3-3))
+	 (result-3-5
+	  (tm-sparql::set-compare-operators dummy-object result-3-4))
+	 (result-3-6
+	  (tm-sparql::set-functions dummy-object result-3-5))
+	 (result-4
+	  (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
+	 (result-4-2-1
+	  (tm-sparql::set-unary-operators dummy-object result-4))
+	 (result-4-2
+	  (tm-sparql::set-or-and-operators dummy-object result-4-2-1 result-4-2-1))
+	 (result-4-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-4-2))
+	 (result-4-4
+	  (tm-sparql::set-+-and---operators dummy-object result-4-3))
+	 (result-4-5
+	  (tm-sparql::set-compare-operators dummy-object result-4-4))
+	 (result-4-6
+	  (tm-sparql::set-functions dummy-object result-4-5))
+	 (result-5
+	  (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string))
+	 (result-5-2-1
+	  (tm-sparql::set-unary-operators dummy-object result-5))
+	 (result-5-2
+	  (tm-sparql::set-or-and-operators dummy-object result-5-2-1 result-5-2-1))
+	 (result-5-3
+	  (tm-sparql::set-*-and-/-operators dummy-object result-5-2))
+	 (result-5-4
+	  (tm-sparql::set-+-and---operators dummy-object result-5-3))
+	 (result-5-5
+	  (tm-sparql::set-compare-operators dummy-object result-5-4))
+	 (result-5-6
+	  (tm-sparql::set-functions dummy-object result-5-5)))
+    (is-true result-1) (is-true result-1-2) (is-true result-1-3)
+    (is-true result-1-4) (is-true result-1-5) (is-true result-1-6)
+    (is-true result-2) (is-true result-2-2) (is-true result-2-3)
+    (is-true result-2-4) (is-true result-2-5) (is-true result-2-6)
+    (is-true result-3) (is-true result-3-2) (is-true result-3-3)
+    (is-true result-3-4) (is-true result-3-5) (is-true result-3-6)
+    (is-true result-4) (is-true result-4-2) (is-true result-4-3)
+    (is-true result-4-4) (is-true result-4-5) (is-true result-4-6)
+    (is-true result-5) (is-true result-5-2) (is-true result-5-3)
+    (is-true result-5-4) (is-true result-5-5) (is-true result-5-6)
+    (is (string= (string-replace result-1-6 " " "")
+		 "(or(progn(BOUND(progn(progn?var))))(progn(progn(and(progn(isLITERAL$var))(progn(=?var\"abc\"))))))"))
+    (is (string= (string-replace result-2-6 " " "")
+		 "(progn(or(progn(REGEX?var1\"\"?var3))(progn(progn(and(progn(>?var1?var3))(progn(progn(=(STR?var)\"abc\"))))))))"))
+    (is (string= (string-replace result-3-6 " " "")
+		 "(or(progn(STR(DATATYPE?var3(isLITERALxy))))(progn(=(one+?var1)(+(one-?var2)(*?var2?var3)))))"))
+    (is (string= (string-replace result-4-6 " " "")
+		 "(or(progn(DATATYPE?var3))(progn(isLITERAL(=(one+?var1)(one-?var2)))))"))
+    (is (string= (string-replace result-5-6 " " "")
+		 "(or(progn(DATATYPE?var3))(progn(progn(isLITERAL(=(one+?var1)(one-?var2))))))"))))
 	 
     
 



From lgiessmann at common-lisp.net  Sun Dec 19 15:18:30 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sun, 19 Dec 2010 10:18:30 -0500
Subject: [isidorus-cvs] r375 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1PUL1q-0003Sy-Jm@common-lisp.net>

Author: lgiessmann
Date: Sun Dec 19 10:18:30 2010
New Revision: 375

Log:
TM-SPARQL: added the scanning of function in sparql-filters that are not allowed, so not authorized calls, e.g. of drop-instance or another lisp functions are detected and therefore not evaluated; changed the form of the return values of sparql-triples, now an uri is embraced in <> => adapt the corresponding unit-tests.

Modified:
   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/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Sun Dec 19 10:18:30 2010
@@ -256,6 +256,14 @@
 	     results)))))
 
 
+(defun embrace-uri(uri-string)
+  "Returns '<'uri-string'>' if uri-string is not a string uri-string
+   is returned as result."
+  (if (typep uri-string 'String)
+      (concatenate 'string "<" uri-string ">")
+      uri-string))
+
+
 (defgeneric filter-by-given-object (construct &key revision)
   (:documentation "Returns a list representing a triple that is the result
                    of a given object.")
@@ -319,8 +327,8 @@
 			  (pred (when-do top (instance-of char :revision revision)
 					 (any-id top :revision revision))))
 		      (when (and subj pred)
-			(list :subject subj
-			      :predicate pred
+			(list :subject (embrace-uri subj)
+			      :predicate (embrace-uri pred)
 			      :object (charvalue char)
 			      :literal-datatyp literal-datatype))))
 	  ;;elephant returns names, occurences, and variants if any string
@@ -355,9 +363,9 @@
 			(when-do plr (player orole :revision revision)
 				 (any-id plr :revision revision))))
 		  (when (and obj-uri pred-uri subj-uri)
-		    (list :subject subj-uri
-			  :predicate pred-uri
-			  :object obj-uri))))
+		    (list :subject (embrace-uri subj-uri)
+			  :predicate (embrace-uri pred-uri)
+			  :object (embrace-uri obj-uri)))))
 	    roles-by-oplayer)))))
 
 
@@ -421,9 +429,9 @@
 			  (when-do plr (player orole :revision revision)
 				   (any-id plr :revision revision))))
 		    (when (and subj-uri pred-uri obj-uri)
-		      (list :subject subj-uri
-			    :predicate pred-uri
-			    :object obj-uri))))
+		      (list :subject (embrace-uri subj-uri)
+			    :predicate (embrace-uri pred-uri)
+			    :object (embrace-uri obj-uri)))))
 	      roles-by-player))))))
 
 
@@ -469,8 +477,8 @@
 			 (when-do top (instance-of name :revision revision)
 				  (any-id top :revision revision))))
 		    (when (and subj pred)
-		      (list :subject subj
-			    :predicate pred
+		      (list :subject (embrace-uri subj)
+			    :predicate (embrace-uri pred)
 			    :object (charvalue name)
 			    :literal-datatype *xml-string*))))
 	      names-by-literal))))))
@@ -509,8 +517,8 @@
 			 (when-do top (instance-of occ :revision revision)
 				  (any-id top :revision revision))))
 		    (when (and subj pred)
-		      (list :subject subj
-			    :predicate pred
+		      (list :subject (embrace-uri subj)
+			    :predicate (embrace-uri pred)
 			    :object (charvalue occ)
 			    :literal-datatype (datatype occ)))))
 	      all-occs))))))
@@ -641,15 +649,17 @@
 		  #'(lambda(occ)
 		      (filter-occ-by-value occ literal-value literal-datatype))
 		  occs-by-type)))
-	   (subj-uri (any-id construct :revision revision)))
+	   (subj-uri (when-do top-uri (any-id construct :revision revision)
+			      top-uri)))
       (remove-null
        (map 'list #'(lambda(occ)
 		      (let ((pred-uri
-			     (when-do type-top (instance-of occ :revision revision)
+			     (when-do type-top
+				      (instance-of occ :revision revision)
 				      (any-id type-top :revision revision))))
 			(when pred-uri
-			  (list :subject subj-uri
-				:predicate pred-uri
+			  (list :subject (embrace-uri subj-uri)
+				:predicate (embrace-uri pred-uri)
 				:object (charvalue occ)
 				:literal-datatype (datatype occ)))))
 	    all-occs)))))
@@ -681,8 +691,8 @@
 			     (when-do type-top (instance-of name :revision revision)
 				      (any-id type-top :revision revision))))
 			(when pred-uri
-			  (list :subject subj-uri
-				:predicate pred-uri
+			  (list :subject (embrace-uri subj-uri)
+				:predicate (embrace-uri pred-uri)
 				:object (charvalue name)
 				:literal-datatype *xml-string*))))
 	    all-names)))))
@@ -747,9 +757,9 @@
 							:revision revision)
 				     (any-id player-top :revision revision)))))
 		    (when (and pred-uri obj-uri)
-		      (list :subject subj-uri
-			    :predicate pred-uri
-			    :object obj-uri)))))
+		      (list :subject (embrace-uri subj-uri)
+			    :predicate (embrace-uri pred-uri)
+			    :object (embrace-uri obj-uri))))))
 	    assocs)))))
 
 

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Sun Dec 19 10:18:30 2010
@@ -24,7 +24,9 @@
 
 
 (defparameter *supported-compare-operators*
-  (list "!=" "<=" ">=" "=" "<" ">") ;not the order is important!
+  (list "!=" "<=" ">=" "=" "<" ">") ;note the order is important!
+                                    ;the operators with length = 2
+                                    ;must be listed first
   "Contains all supported binary operators.")
 
 
@@ -36,6 +38,12 @@
   (list "!" "+" "-") "Contains all supported unary operators")
 
 
+(defparameter *allowed-filter-calls*
+  (append (list "one+" "one-" "progn" "or" "and" "not" "/=" "="
+		">" ">=" "<" "<=" "+" "-" "*" "/")
+	  *supported-functions*))
+
+
 (defun *2-compare-operators* ()
   (remove-null
    (map 'list #'(lambda(op)
@@ -88,37 +96,75 @@
 
 (defgeneric parse-filter (construct query-string)
   (:documentation "A helper functions that returns a filter and the next-query
-                   string in the form (:next-query string :filter object).")
+                   string in the form (:next-query string
+                   :filter-string object).")
   (:method ((construct SPARQL-Query) (query-string String))
     ;note the order of the invacations is important!
     (let* ((result-set-boundings (set-boundings construct query-string))
 	   (filter-string (getf result-set-boundings :filter-string))
 	   (next-query (getf result-set-boundings :next-query))
+	   (original-filter-string
+	    (subseq query-string 0 (- (length query-string)
+				      (length next-query))))
 	   (filter-string-unary-ops
 	    (set-unary-operators construct filter-string))
 	   (filter-string-or-and-ops
 	    (set-or-and-operators construct filter-string-unary-ops
-				  filter-string-unary-ops))
+				  original-filter-string))
 	   (filter-string-arithmetic-ops
 	    (set-arithmetic-operators construct filter-string-or-and-ops))
 	   (filter-string-compare-ops
 	    (set-compare-operators construct filter-string-arithmetic-ops))
 	   (filter-string-functions
 	    (set-functions construct filter-string-compare-ops)))
-      filter-string-functions)))
+      (list :next-query next-query
+	    :filter-string (scan-filter-for-deprecated-calls
+			    construct filter-string-functions original-filter-string)))))
   ;;TODO: implement
-  ;; *check if all functions that will be invoked are allowed
   ;; *implement wrapper functions, also for the operators
   ;;   it would be nice of the self defined operator functions would be in a
   ;;   separate packet, e.g. filter-functions, so =, ... would couse no
   ;;   collisions
-  ;; *embrace the final results uris in <> => unit-tests
   ;; *create and store this filter object => store the created string and implement
   ;;   a method "invoke-filter(SPARQL-Triple filter-string)" so that the variables
   ;;   are automatically contained in a letafterwards the eval function can be called
   ;;   this method should also have a let with (true t) and (false nil)
 
 
+(defgeneric scan-filter-for-deprecated-calls (construct filter-string
+							original-filter)
+  (:documentation "Returns the passed filter-string or throws a
+                   sparql-parser-error of there is an unallowed
+                   function call.")
+  (:method ((construct SPARQL-Query) (filter-string String)
+	    (original-filter String))
+    (dotimes (idx (length filter-string) filter-string)
+      (when-do fun-name (return-function-name (subseq filter-string idx))
+	       (unless (string-starts-with-one-of fun-name *supported-functions*)
+		 (error 
+		  (make-condition
+		   'exceptions:sparql-parser-error
+		   :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the depricated function ~a!"
+				    filter-string original-filter fun-name))))))))
+	       
+
+
+(defun return-function-name (filter-string)
+  "If the string starts with ( there is returned the function name
+   that is placed directly after the (."
+  (declare (String filter-string))
+  (when (string-starts-with filter-string "(")
+    (let ((local-str (trim-whitespace-left (subseq filter-string 1)))
+	  (whitespaces (map 'list #'string (white-space)))
+	  (result ""))
+      (dotimes (idx (length local-str) result)
+	(let ((current-char (subseq local-str idx (1+ idx))))
+	  (if (string-starts-with-one-of
+	       current-char (append whitespaces *supported-brackets*))
+	      (setf idx (length local-str))
+	      (push-string current-char result)))))))
+
+
 (defgeneric set-functions (construct filter-string)
   (:documentation "Transforms all supported functions of the form
                    function(x, y) to (function x y).")
@@ -695,7 +741,7 @@
 
 
 (defun function-scope (str)
-  "If str starts with a supported function it there is given the entire substr
+  "If str starts with a supported function there is given the entire substr
    that is the scope of the function, i.e. the function name and all its
    variable including the closing )."
   (declare (String str))

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Sun Dec 19 10:18:30 2010
@@ -510,14 +510,18 @@
     result-idx))
 
 
-(defun return-if-starts-with (str to-be-matched &key from-end ignore-case)
+(defun return-if-starts-with (str to-be-matched &key from-end ignore-case
+			      ignore-leading-whitespace)
   "Returns the string that is contained in to-be-matched and that is the
    start of the string str."
   (declare (String str)
 	   (List to-be-matched)
-	   (Boolean from-end ignore-case))
-  (loop for try in to-be-matched
-     when (if from-end
-	      (string-ends-with str try :ignore-case ignore-case)
-	      (string-starts-with str try :ignore-case ignore-case))
-     return try))
\ No newline at end of file
+	   (Boolean from-end ignore-case ignore-leading-whitespace))
+  (let ((cleaned-str (if ignore-leading-whitespace
+			 (trim-whitespace-left str)
+			 str)))
+    (loop for try in to-be-matched
+       when (if from-end
+		(string-ends-with cleaned-str try :ignore-case ignore-case)
+		(string-starts-with cleaned-str try :ignore-case ignore-case))
+       return try)))
\ No newline at end of file

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Sun Dec 19 10:18:30 2010
@@ -457,24 +457,24 @@
 			      (first (tm-sparql::select-group q-obj-2)))))
 	      (obj-2 (second (tm-sparql::object-result
 			       (first (tm-sparql::select-group q-obj-2))))))
-	  (cond ((or (string= subj-1 "http://some.where/psis/author/goethe")
-		     (string= subj-1 "http://some.where/psis/persons/goethe"))
-		 (is (string= pred-1 "http://some.where/base-psis/written"))
-		 (is (or (string= obj-1 "http://some.where/psis/poem/zauberlehrling")
-			 (string= obj-1 "http://some.where/psis/der_zauberlehrling")))
-		 (is (string= subj-2 "http://some.where/base-psis/poem"))
-		 (is (string= pred-2 "http://psi.topicmaps.org/iso13250/model/instance"))
-		 (is (or (string= obj-2 "http://some.where/psis/poem/zauberlehrling")
-			 (string= obj-2 "http://some.where/psis/der_zauberlehrling"))))
-		((string= subj-1 "http://some.where/base-psis/poem")
-		 (is (string= pred-2 "http://some.where/base-psis/written"))
-		 (is (or (string= obj-1 "http://some.where/psis/poem/zauberlehrling")
-			 (string= obj-1 "http://some.where/psis/der_zauberlehrling")))
-		 (is (or (string= subj-2 "http://some.where/psis/author/goethe")
-			 (string= subj-2 "http://some.where/psis/persons/goethe")))
-		 (is (string= pred-1 "http://psi.topicmaps.org/iso13250/model/type"))
-		 (is (or (string= obj-2 "http://some.where/psis/poem/zauberlehrling")
-			 (string= obj-2 "http://some.where/psis/der_zauberlehrling"))))
+	  (cond ((or (string= subj-1 "<http://some.where/psis/author/goethe>")
+		     (string= subj-1 "<http://some.where/psis/persons/goethe>"))
+		 (is (string= pred-1 "<http://some.where/base-psis/written>"))
+		 (is (or (string= obj-1 "<http://some.where/psis/poem/zauberlehrling>")
+			 (string= obj-1 "<http://some.where/psis/der_zauberlehrling>")))
+		 (is (string= subj-2 "<http://some.where/base-psis/poem>"))
+		 (is (string= pred-2 "<http://psi.topicmaps.org/iso13250/model/instance>"))
+		 (is (or (string= obj-2 "<http://some.where/psis/poem/zauberlehrling>")
+			 (string= obj-2 "<http://some.where/psis/der_zauberlehrling>"))))
+		((string= subj-1 "<http://some.where/base-psis/poem>")
+		 (is (string= pred-2 "<http://some.where/base-psis/written>"))
+		 (is (or (string= obj-1 "<http://some.where/psis/poem/zauberlehrling>")
+			 (string= obj-1 "<http://some.where/psis/der_zauberlehrling>")))
+		 (is (or (string= subj-2 "<http://some.where/psis/author/goethe>")
+			 (string= subj-2 "<http://some.where/psis/persons/goethe>")))
+		 (is (string= pred-1 "<http://psi.topicmaps.org/iso13250/model/type>"))
+		 (is (or (string= obj-2 "<http://some.where/psis/poem/zauberlehrling>")
+			 (string= obj-2 "<http://some.where/psis/der_zauberlehrling>"))))
 		(t
 		 (is-true nil))))
 	(is (= (length (tm-sparql::subject-result
@@ -485,13 +485,13 @@
 			(first (tm-sparql::select-group q-obj-3)))) 1))
 	(is (or (string= (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-3))))
-			 "http://some.where/psis/author/goethe")
+			 "<http://some.where/psis/author/goethe>")
 		(string= (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-3))))
-			 "http://some.where/psis/persons/goethe")))
+			 "<http://some.where/psis/persons/goethe>")))
 	(is (string= (first (tm-sparql::predicate-result
 			     (first (tm-sparql::select-group q-obj-3))))
-		     "http://some.where/base-psis/first-name"))
+		     "<http://some.where/base-psis/first-name>"))
 	(is (string= (first (tm-sparql::object-result
 			     (first (tm-sparql::select-group q-obj-3))))
 		     "Johann Wolfgang"))))))
@@ -547,27 +547,27 @@
 			    (first (tm-sparql::select-group q-obj-1)))))
 	       (o-4 (fourth (tm-sparql::object-result
 			     (first (tm-sparql::select-group q-obj-1))))))
-	  (is (string= p-1 "http://some.where/base-psis/written"))
-	  (is (string= p-2 "http://some.where/base-psis/written"))
-	  (is (string= p-3 "http://some.where/base-psis/written"))
-	  (is (string= p-4 "http://some.where/base-psis/written"))
+	  (is (string= p-1 "<http://some.where/base-psis/written>"))
+	  (is (string= p-2 "<http://some.where/base-psis/written>"))
+	  (is (string= p-3 "<http://some.where/base-psis/written>"))
+	  (is (string= p-4 "<http://some.where/base-psis/written>"))
 	  (is (or (not (set-exclusive-or
-			(list "http://some.where/psis/author/eichendorff"
-			      "http://some.where/psis/author/schiller"
-			      "http://some.where/psis/author/goethe")
+			(list "<http://some.where/psis/author/eichendorff>"
+			      "<http://some.where/psis/author/schiller>"
+			      "<http://some.where/psis/author/goethe>")
 			(list s-1 s-2 s-3 s-4)
 			:test #'string=))
 		  (not (set-exclusive-or
-			(list "http://some.where/psis/author/eichendorff"
-			      "http://some.where/psis/author/schiller"
-			      "http://some.where/psis/persons/goethe")
+			(list "<http://some.where/psis/author/eichendorff>"
+			      "<http://some.where/psis/author/schiller>"
+			      "<http://some.where/psis/persons/goethe>")
 			(list s-1 s-2 s-3 s-4)
 			:test #'string=))))
 	  (is-false (set-exclusive-or
-		     (list "http://some.where/psis/poem/mondnacht"
-			   "http://some.where/psis/poem/resignation"
-			   "http://some.where/psis/poem/erlkoenig"
-			   "http://some.where/psis/poem/zauberlehrling")
+		     (list "<http://some.where/psis/poem/mondnacht>"
+			   "<http://some.where/psis/poem/resignation>"
+			   "<http://some.where/psis/poem/erlkoenig>"
+			   "<http://some.where/psis/poem/zauberlehrling>")
 		     (list o-1 o-2 o-3 o-4)
 		     :test #'string=)))
 	(is-true q-obj-2)
@@ -595,47 +595,47 @@
 			    (first (tm-sparql::select-group q-obj-2)))))
 	       (o-3 (third (tm-sparql::object-result
 			    (first (tm-sparql::select-group q-obj-2))))))
-	  (string= p-1 "http://some.where/base-psis/first-name")
-	  (string= p-2 "http://some.where/base-psis/first-name")
-	  (string= p-3 "http://some.where/base-psis/first-name")
+	  (string= p-1 "<http://some.where/base-psis/first-name>")
+	  (string= p-2 "<http://some.where/base-psis/first-name>")
+	  (string= p-3 "<http://some.where/base-psis/first-name>")
 	  (cond ((string= o-1 "Johann Christoph Friedrich")
-		 (is (string= s-1 "http://some.where/psis/author/schiller"))
+		 (is (string= s-1 "<http://some.where/psis/author/schiller>"))
 		 (cond ((string= o-2 "Johann Wolfgang")
-			(is (or (string= s-2 "http://some.where/psis/author/goethe")
-				(string= s-2 "http://some.where/psis/persons/goethe")))
-			(is (string= s-3 "http://some.where/psis/author/eichendorff"))
+			(is (or (string= s-2 "<http://some.where/psis/author/goethe>")
+				(string= s-2 "<http://some.where/psis/persons/goethe>")))
+			(is (string= s-3 "<http://some.where/psis/author/eichendorff>"))
 			(is (string= o-3 "Joseph Karl Benedikt")))
 		       ((string= o-2 "Joseph Karl Benedikt")
-			(is (string= s-2 "http://some.where/psis/author/eichendorff"))
-			(is (or (string= s-3 "http://some.where/psis/author/goethe")
-				(string= s-3 "http://some.where/psis/persons/goethe")))
+			(is (string= s-2 "<http://some.where/psis/author/eichendorff>"))
+			(is (or (string= s-3 "<http://some.where/psis/author/goethe>")
+				(string= s-3 "<http://some.where/psis/persons/goethe>")))
 			(is (string= o-3 "Johann Wolfgang")))
 		       (t
 			(is-true nil))))
 		((string= o-1 "Johann Wolfgang")
-		 (is (or (string= s-1 "http://some.where/psis/author/goethe")
-			 (string= s-1 "http://some.where/psis/persons/goethe")))
+		 (is (or (string= s-1 "<http://some.where/psis/author/goethe>")
+			 (string= s-1 "<http://some.where/psis/persons/goethe>")))
 		 (cond ((string= o-2 "Johann Christoph Friedrich")
-			(is (string= s-2 "http://some.where/psis/author/schiller"))
-			(is (string= s-3 "http://some.where/psis/author/eichendorff"))
+			(is (string= s-2 "<http://some.where/psis/author/schiller>"))
+			(is (string= s-3 "<http://some.where/psis/author/eichendorff>"))
 			(is (string= o-3 "Joseph Karl Benedikt")))
 		       ((string= o-2 "Joseph Karl Benedikt")
-			(is (string= s-2 "http://some.where/psis/author/eichendorff"))
-			(is (string= s-3 "http://some.where/psis/author/schiller"))
+			(is (string= s-2 "<http://some.where/psis/author/eichendorff>"))
+			(is (string= s-3 "<http://some.where/psis/author/schiller>"))
 			(is (string= o-3 "Johann Christoph Friedrich")))
 		       (t
 			(is-true nil))))
 		((string= o-1 "Joseph Karl Benedikt")
-		 (is (string= s-1 "http://some.where/psis/author/eichendorff"))
+		 (is (string= s-1 "<http://some.where/psis/author/eichendorff>"))
 		 (cond ((string= o-2 "Johann Wolfgang")
-			(is (or (string= s-2 "http://some.where/psis/author/goethe")
-				(string= s-2 "http://some.where/psis/persons/goethe")))
-			(is (string= s-3 "http://some.where/psis/author/schiller"))
+			(is (or (string= s-2 "<http://some.where/psis/author/goethe>")
+				(string= s-2 "<http://some.where/psis/persons/goethe>")))
+			(is (string= s-3 "<http://some.where/psis/author/schiller>"))
 			(is (string= o-3 "Johann Christoph Friedrich")))
 		       ((string= o-2 "Johann Christoph Friedrich")
-			(is (string= s-2 "http://some.where/psis/author/schiller"))
-			(is (or (string= s-3 "http://some.where/psis/author/goethe")
-				(string= s-3 "http://some.where/psis/persons/goethe")))
+			(is (string= s-2 "<http://some.where/psis/author/schiller>"))
+			(is (or (string= s-3 "<http://some.where/psis/author/goethe>")
+				(string= s-3 "<http://some.where/psis/persons/goethe>")))
 			(is (string= o-3 "Johann Wolfgang")))
 		       (t
 			(is-true nil))))
@@ -651,16 +651,16 @@
 			(first (tm-sparql::select-group q-obj-3)))) 1))
 	(is (or (string= (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-3))))
-			 "http://some.where/psis/author/goethe")
+			 "<http://some.where/psis/author/goethe>")
 		(string= (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-3))))
-			 "http://some.where/psis/persons/goethe")))
+			 "<http://some.where/psis/persons/goethe>")))
 	(is (string= (first (tm-sparql::predicate-result
 			     (first (tm-sparql::select-group q-obj-3))))
-		     "http://some.where/base-psis/written"))
+		     "<http://some.where/base-psis/written>"))
 	(is (string= (first (tm-sparql::object-result
 			     (first (tm-sparql::select-group q-obj-3))))
-		     "http://some.where/psis/poem/zauberlehrling"))))))
+		     "<http://some.where/psis/poem/zauberlehrling>"))))))
 
 
 (test test-set-result-3
@@ -700,25 +700,25 @@
 			(first (tm-sparql::select-group q-obj-3)))) 0))
 	(is (or (string= (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-1))))
-			 "http://some.where/psis/author/goethe")
+			 "<http://some.where/psis/author/goethe>")
 		(string= (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-1))))
-			 "http://some.where/psis/persons/goethe")))
+			 "<http://some.where/psis/persons/goethe>")))
 	(is (string= (first (tm-sparql::predicate-result
 			     (first (tm-sparql::select-group q-obj-1))))
-		     "http://some.where/base-psis/author-info"))
+		     "<http://some.where/base-psis/author-info>"))
 	(is (string= (first (tm-sparql::object-result
 			     (first (tm-sparql::select-group q-obj-1))))
 		     "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe"))
 	(is (string= (first (tm-sparql::subject-result
 			     (first (tm-sparql::select-group q-obj-4))))
-		     "http://some.where/psis/author/schiller"))
+		     "<http://some.where/psis/author/schiller>"))
 	(is (string= (first (tm-sparql::predicate-result
 			     (first (tm-sparql::select-group q-obj-4))))
-		     "http://some.where/base-psis/written"))
+		     "<http://some.where/base-psis/written>"))
 	(is (string= (first (tm-sparql::object-result
 			     (first (tm-sparql::select-group q-obj-4))))
-		     "http://some.where/psis/poem/resignation"))))))
+		     "<http://some.where/psis/poem/resignation>"))))))
 
 
 (test test-set-result-4
@@ -749,91 +749,91 @@
 	(is (= (length (tm-sparql::subject-result
 			(first (tm-sparql::select-group q-obj-3)))) 1))
 	(is-true (or (null (set-exclusive-or
-			    (list "http://some.where/psis/author/goethe")
+			    (list "<http://some.where/psis/author/goethe>")
 			    (tm-sparql::subject-result
 			     (first (tm-sparql::select-group q-obj-1)))
 			    :test #'string=))
 		     (null (set-exclusive-or
-			    (list "http://some.where/psis/persons/goethe")
+			    (list "<http://some.where/psis/persons/goethe>")
 			    (tm-sparql::subject-result
 			     (first (tm-sparql::select-group q-obj-1)))
 			    :test #'string=))))
 	(let ((predicates (tm-sparql::predicate-result
 			   (first (tm-sparql::select-group q-obj-1)))))
-	  (is (= (count "http://some.where/base-psis/written" predicates
+	  (is (= (count "<http://some.where/base-psis/written>" predicates
 			:test #'string=) 2))
-	  (is (= (count "http://some.where/base-psis/place" predicates
+	  (is (= (count "<http://some.where/base-psis/place>" predicates
 			:test #'string=) 1))
-	  (is (= (count "http://some.where/base-psis/first-name" predicates
+	  (is (= (count "<http://some.where/base-psis/first-name>" predicates
 			:test #'string=) 1))
-	  (is (= (count "http://some.where/base-psis/last-name" predicates
+	  (is (= (count "<http://some.where/base-psis/last-name>" predicates
 			:test #'string=) 1))
-	  (is (= (count "http://some.where/base-psis/author-info" predicates
+	  (is (= (count "<http://some.where/base-psis/author-info>" predicates
 			:test #'string=) 1))
-	  (is (= (count "http://psi.topicmaps.org/iso13250/model/type" predicates
+	  (is (= (count "<http://psi.topicmaps.org/iso13250/model/type>" predicates
 			:test #'string=) 1)))
 	(let ((objects (tm-sparql::object-result
 			(first (tm-sparql::select-group q-obj-1)))))
-	  (is (= (count "http://some.where/psis/poem/erlkoenig" objects
+	  (is (= (count "<http://some.where/psis/poem/erlkoenig>" objects
 			:test #'string=) 1))
-	  (is (or (= (count "http://some.where/psis/poem/der_zauberlehrling"
+	  (is (or (= (count "<http://some.where/psis/poem/der_zauberlehrling>"
 			    objects :test #'string=) 1)
-		  (= (count "http://some.where/psis/poem/zauberlehrling" objects
+		  (= (count "<http://some.where/psis/poem/zauberlehrling>" objects
 			    :test #'string=) 1)))
-	  (is (or (= (count "http://some.where/base-psis/author" objects
+	  (is (or (= (count "<http://some.where/base-psis/author>" objects
 			    :test #'string=) 1)
-		  (= (count "http://some.where/base-psis/author-psi" objects
+		  (= (count "<http://some.where/base-psis/author-psi>" objects
 			    :test #'string=) 1)))
 	  (is (= (count "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe"
 			objects :test #'string=) 1))
 	  (is (= (count "von Goethe" objects :test #'string=) 1))
 	  (is (= (count "Johann Wolfgang" objects :test #'string=) 1))
-	  (is (= (count "http://some.where/psis/region/frankfurt_am_main"
+	  (is (= (count "<http://some.where/psis/region/frankfurt_am_main>"
 			objects :test #'string=) 1)))
 	(is-true (or (null (set-exclusive-or
-			    (list "http://some.where/psis/poem/der_zauberlehrling")
+			    (list "<http://some.where/psis/poem/der_zauberlehrling>")
 			    (tm-sparql::subject-result
 			     (first (tm-sparql::select-group q-obj-2)))
 			    :test #'string=))
 		     (null (set-exclusive-or
-			    (list "http://some.where/psis/poem/zauberlehrling")
+			    (list "<http://some.where/psis/poem/zauberlehrling>")
 			    (tm-sparql::subject-result
 			     (first (tm-sparql::select-group q-obj-2)))
 			    :test #'string=))))
 	(let ((predicates (tm-sparql::predicate-result
 			   (first (tm-sparql::select-group q-obj-2)))))
-	  (is (= (count "http://some.where/base-psis/writer" predicates
+	  (is (= (count "<http://some.where/base-psis/writer>" predicates
 			:test #'string=) 1))
-	  (is (= (count "http://some.where/base-psis/title" predicates
+	  (is (= (count "<http://some.where/base-psis/title>" predicates
 			:test #'string=) 1))
-	  (is (= (count "http://some.where/base-psis/poem-content" predicates
+	  (is (= (count "<http://some.where/base-psis/poem-content>" predicates
 			:test #'string=) 1))
-	  (is (= (count "http://psi.topicmaps.org/iso13250/model/type" predicates
+	  (is (= (count "<http://psi.topicmaps.org/iso13250/model/type>" predicates
 			:test #'string=) 1)))
 	(let ((objects (tm-sparql::object-result
 			(first (tm-sparql::select-group q-obj-2)))))
-	  (is (or (= (count "http://some.where/psis/author/goethe" objects
+	  (is (or (= (count "<http://some.where/psis/author/goethe>" objects
 			    :test #'string=) 1)
-		  (= (count "http://some.where/psis/persons/goethe" objects
+		  (= (count "<http://some.where/psis/persons/goethe>" objects
 			    :test #'string=) 1)))
 	  (is (= (count "Der Zauberlehrling" objects :test #'string=) 1))
-	  (is (= (count "http://some.where/base-psis/poem"
+	  (is (= (count "<http://some.where/base-psis/poem>"
 			objects :test #'string=) 1))
 	  ;do not check the entire poem content => too long
 	  )
-	(is (or (string= "http://some.where/psis/author/goethe"
+	(is (or (string= "<http://some.where/psis/author/goethe>"
 			 (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-3)))))
-		(string= "http://some.where/psis/persons/goethe"
+		(string= "<http://some.where/psis/persons/goethe>"
 			 (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-3)))))))
-	(is (string= "http://some.where/base-psis/written"
+	(is (string= "<http://some.where/base-psis/written>"
 		     (first (tm-sparql::predicate-result
 			     (first (tm-sparql::select-group q-obj-3))))))
-	(is (or (string= "http://some.where/psis/poem/der_zauberlehrling"
+	(is (or (string= "<http://some.where/psis/poem/der_zauberlehrling>"
 			 (first (tm-sparql::object-result
 				 (first (tm-sparql::select-group q-obj-3)))))
-		(string= "http://some.where/psis/poem/zauberlehrling"
+		(string= "<http://some.where/psis/poem/zauberlehrling>"
 			 (first (tm-sparql::object-result
 				 (first (tm-sparql::select-group q-obj-3)))))))))))
 
@@ -868,52 +868,52 @@
 			(first (tm-sparql::select-group q-obj-3)))) 0))
 	(is (= (length (tm-sparql::subject-result
 			(second (tm-sparql::select-group q-obj-3)))) 1))
-	(is (or (string= "http://some.where/psis/author/goethe"
+	(is (or (string= "<http://some.where/psis/author/goethe>"
 			 (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-1)))))
-		(string= "http://some.where/psis/persons/goethe"
+		(string= "<http://some.where/psis/persons/goethe>"
 			 (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-1)))))))
-	(is (string= "http://some.where/base-psis/first-name"
+	(is (string= "<http://some.where/base-psis/first-name>"
 		     (first (tm-sparql::predicate-result
 			     (first (tm-sparql::select-group q-obj-1))))))
 	(is (string= "Johann Wolfgang"
 		     (first (tm-sparql::object-result
 			     (first (tm-sparql::select-group q-obj-1))))))
-	(is (or (string= "http://some.where/psis/author/goethe"
+	(is (or (string= "<http://some.where/psis/author/goethe>"
 			 (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-2)))))
-		(string= "http://some.where/psis/persons/goethe"
+		(string= "<http://some.where/psis/persons/goethe>"
 			 (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-2)))))))
-	(is (string= "http://some.where/base-psis/written"
+	(is (string= "<http://some.where/base-psis/written>"
 		     (first (tm-sparql::predicate-result
 			     (first (tm-sparql::select-group q-obj-2))))))
-	(is (or (string= "http://some.where/psis/poem/zauberlehrling"
+	(is (or (string= "<http://some.where/psis/poem/zauberlehrling>"
 			 (first (tm-sparql::object-result
 				 (first (tm-sparql::select-group q-obj-2)))))
-		(string= "http://some.where/psis/poem/der_zauberlehrling"
+		(string= "<http://some.where/psis/poem/der_zauberlehrling>"
 			 (first (tm-sparql::object-result
 				 (first (tm-sparql::select-group q-obj-2)))))
-		(string= "http://some.where/psis/poem/erlkoenig"
+		(string= "<http://some.where/psis/poem/erlkoenig>"
 			 (first (tm-sparql::object-result
 				 (first (tm-sparql::select-group q-obj-2)))))))
-	(is (or (string= "http://some.where/psis/author/goethe"
+	(is (or (string= "<http://some.where/psis/author/goethe>"
 			 (second (tm-sparql::subject-result
 				  (first (tm-sparql::select-group q-obj-2)))))
-		(string= "http://some.where/psis/persons/goethe"
+		(string= "<http://some.where/psis/persons/goethe>"
 			 (second (tm-sparql::subject-result
 				  (first (tm-sparql::select-group q-obj-2)))))))
-	(is (string= "http://some.where/base-psis/written"
+	(is (string= "<http://some.where/base-psis/written>"
 		     (second (tm-sparql::predicate-result
 			      (first (tm-sparql::select-group q-obj-2))))))
-	(is (or (string= "http://some.where/psis/poem/zauberlehrling"
+	(is (or (string= "<http://some.where/psis/poem/zauberlehrling>"
 			 (second (tm-sparql::object-result
 				  (first (tm-sparql::select-group q-obj-2)))))
-		(string= "http://some.where/psis/poem/der_zauberlehrling"
+		(string= "<http://some.where/psis/poem/der_zauberlehrling>"
 			 (second (tm-sparql::object-result
 				  (first (tm-sparql::select-group q-obj-2)))))
-		(string= "http://some.where/psis/poem/erlkoenig"
+		(string= "<http://some.where/psis/poem/erlkoenig>"
 			 (second (tm-sparql::object-result
 				  (first (tm-sparql::select-group q-obj-2)))))))
 	(is-false (first (tm-sparql::subject-result
@@ -922,13 +922,13 @@
 			  (first (tm-sparql::select-group q-obj-3)))))
 	(is-false (first (tm-sparql::object-result
 			  (first (tm-sparql::select-group q-obj-3)))))
-	(is (or (string= "http://some.where/psis/author/goethe"
+	(is (or (string= "<http://some.where/psis/author/goethe>"
 			 (first (tm-sparql::subject-result
 				 (second (tm-sparql::select-group q-obj-3)))))
-		(string= "http://some.where/psis/persons/goethe"
+		(string= "<http://some.where/psis/persons/goethe>"
 			 (first (tm-sparql::subject-result
 				 (second (tm-sparql::select-group q-obj-3)))))))
-	(is (string= "http://some.where/base-psis/last-name"
+	(is (string= "<http://some.where/base-psis/last-name>"
 		     (first (tm-sparql::predicate-result
 			     (second (tm-sparql::select-group q-obj-3))))))
 	(is (string= "von Goethe"
@@ -965,22 +965,22 @@
 	    (progn
 	      (is (= (length (getf (first (result q-obj-1)) :result)) 1))
 	      (is (or (string= (first (getf (first (result q-obj-1)) :result))
-			       "http://some.where/psis/author/goethe")
+			       "<http://some.where/psis/author/goethe>")
 		      (string= (first (getf (first (result q-obj-1)) :result))
-			       "http://some.where/psis/persons/goethe")))
+			       "<http://some.where/psis/persons/goethe>")))
 	      (is (= (length (getf (second (result q-obj-1)) :result)) 1))
 	      (is (string= (first (getf (second (result q-obj-1)) :result))
-			   "http://some.where/psis/poem/erlkoenig"))
-	      (is (string= (getf (second (result q-obj-1)) :variable) "poems")))
+			   "<http://some.where/psis/poem/erlkoenig>"))
+	      (is (string= (getf (second (result q-obj-1)) :variable) "<poems")))
 	    (progn
 	      (is (= (length (getf (second (result q-obj-1)) :result)) 1))
 	      (is (or (string= (first (getf (second (result q-obj-1)) :result))
-			       "http://some.where/psis/author/goethe")
+			       "<http://some.where/psis/author/goethe>")
 		      (string= (first (getf (second (result q-obj-1)) :result))
-			       "http://some.where/psis/persons/goethe")))
+			       "<http://some.where/psis/persons/goethe>")))
 	      (is (= (length (getf (first (result q-obj-1)) :result)) 1))
 	      (is (string= (first (getf (first (result q-obj-1)) :result))
-			   "http://some.where/psis/poem/erlkoenig"))
+			   "<http://some.where/psis/poem/erlkoenig>"))
 	      (is (string= (getf (first (result q-obj-1)) :variable) "poems"))))
 	(is (= (length (result q-obj-2)) 2))
 	(if (string= (getf (first (result q-obj-2)) :variable) "titles")
@@ -1000,19 +1000,19 @@
 		     (getf (first (result q-obj-2)) :result) :test #'string=))
 	      (string= (getf (second (result q-obj-2)) :variable) "poems")
 	      (is-true
-	       (find "http://some.where/psis/poem/mondnacht"
+	       (find "<http://some.where/psis/poem/mondnacht>"
 		     (getf (second (result q-obj-2)) :result) :test #'string=))
 	      (is-true
-	       (find "http://some.where/psis/poem/resignation"
+	       (find "<http://some.where/psis/poem/resignation>"
 		     (getf (second (result q-obj-2)) :result) :test #'string=))
 	      (is-true
-	       (find "http://some.where/psis/poem/erlkoenig"
+	       (find "<http://some.where/psis/poem/erlkoenig>"
 		     (getf (second (result q-obj-2)) :result) :test #'string=))
 	      (is-true
 	       (or
-		(find "http://some.where/psis/poem/zauberlehrling"
+		(find "<http://some.where/psis/poem/zauberlehrling>"
 		      (getf (second (result q-obj-2)) :result) :test #'string=)
-		(find "http://some.where/psis/poem/der_zauberlehrling"
+		(find "<http://some.where/psis/poem/der_zauberlehrling>"
 		      (getf (second (result q-obj-2)) :result) :test #'string=))))
 	    (progn
 	      (is (= (length (getf (second (result q-obj-2)) :result)) 4))
@@ -1030,19 +1030,19 @@
 		     (getf (second (result q-obj-2)) :result) :test #'string=))
 	      (string= (getf (first (result q-obj-2)) :variable) "poems")
 	      (is-true
-	       (find "http://some.where/psis/poem/mondnacht"
+	       (find "<http://some.where/psis/poem/mondnacht>"
 		     (getf (first (result q-obj-2)) :result) :test #'string=))
 	      (is-true
-	       (find "http://some.where/psis/poem/resignation"
+	       (find "<http://some.where/psis/poem/resignation>"
 		     (getf (first (result q-obj-2)) :result) :test #'string=))
 	      (is-true
-	       (find "http://some.where/psis/poem/erlkoenig"
+	       (find "<http://some.where/psis/poem/erlkoenig>"
 		     (getf (first (result q-obj-2)) :result) :test #'string=))
 	      (is-true
 	       (or
-		(find "http://some.where/psis/poem/zauberlehrling"
+		(find "<http://some.where/psis/poem/zauberlehrling>"
 		      (getf (first (result q-obj-2)) :result) :test #'string=)
-		(find "http://some.where/psis/poem/der_zauberlehrling"
+		(find "<http://some.where/psis/poem/der_zauberlehrling>"
 		      (getf (first (result q-obj-2)) :result) :test #'string=)))))))))
 
 



From lgiessmann at common-lisp.net  Sun Dec 19 21:00:03 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sun, 19 Dec 2010 16:00:03 -0500
Subject: [isidorus-cvs] r376 - in trunk/src: . TM-SPARQL base-tools
Message-ID: <E1PUQMM-0000Sj-Ua@common-lisp.net>

Author: lgiessmann
Date: Sun Dec 19 16:00:02 2010
New Revision: 376

Log:
TM-SPARQL: implemented all wrapper functions for filters in a separate package

Added:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/base-tools/base-tools.lisp
   trunk/src/isidorus.asd

Added: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- (empty file)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Sun Dec 19 16:00:02 2010
@@ -0,0 +1,146 @@
+;;+-----------------------------------------------------------------------------
+;;+  Isidorus
+;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
+;;+
+;;+  Isidorus is freely distributable under the LLGPL license.
+;;+  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
+;;+  trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+
+(defpackage :filter-functions
+  (:use :base-tools :constants :tm-sparql))
+
+
+(defun filter-functions::not(x)
+  (not x))
+
+
+(defun filter-functions::one+(x)
+  (1+ x))
+
+
+(defun filter-functions::one-(x)
+  (1- x))
+
+
+(defun filter-functions::+(x y)
+  (+ x y))
+
+
+(defun filter-functions::-(x y)
+  (- x y))
+
+
+(defun filter-functions::*(x y)
+  (* x y))
+
+
+(defun filter-functions::/(x y)
+  (/ x y))
+
+
+(defun filter-functions::or(x y)
+  (or x y))
+
+
+(defun filter-functions::and(x y)
+  (and x y))
+
+
+(defun filter-functions::=(x y)
+  (cond ((and (stringp x) (stringp y))
+	 (string= x y))
+	((and (numberp x)( numberp y))
+	 (= x y))
+	(t
+	 (eql x y))))
+
+
+(defun filter-functions::!=(x y)
+  (filter-functions::not
+   (filter-functions::= x y)))
+
+
+(defun filter-functions::<(x y)
+  (cond ((and (numberp x) (numberp y))
+	 (< x y))
+	((and (stringp x) (stringp y))
+	 (string< x y))
+	((and (typep x 'Boolean) (typep y 'Boolean))
+	 (and (not x) y))
+	(t
+	 nil)))
+
+
+(defun filter-functions::>(x y)
+  (filter-functions::not
+   (filter-functions::< x y)))
+
+
+(defun filter-functions::<=(x y)
+  (filter-functions::or
+   (filter-functions::< x y)
+   (filter-functions::= x y)))
+
+
+(defun filter-functions::>=(x y)
+  (filter-functions::or
+   (filter-functions::> x y)
+   (filter-functions::= x y)))
+	   
+
+(defun filter-functions::regex(str pattern &optional flags)
+  (declare (Ignorable flags))
+  (let* ((case-insensitive (when (find #\i flags) t))
+	 (multi-line (when (find #\m flags) t))
+	 (single-line (when (find #\s flags) t))
+      	 (local-pattern
+	  (if (find #\x flags)
+	      (base-tools:string-replace
+	       (base-tools:string-replace
+		(base-tools:string-replace
+		 (base-tools:string-replace pattern (string #\newline) "")
+		 (string #\tab) "") (string #\cr) "") " " "")
+	      pattern))
+	 (scanner
+	  (ppcre:create-scanner local-pattern
+				:case-insensitive-mode case-insensitive
+				:multi-line-mode multi-line
+				:single-line-mode single-line)))
+    (ppcre:scan scanner str)))
+
+
+(defun filter-functions::bound(x)
+  (boundp x))
+
+
+(defun filter-functions::isLITERAL(x)
+  (or (numberp x)
+      (not (and (base-tools:string-starts-with x "<")
+		(base-tools:string-ends-with x ">")
+		(base-tools:absolute-uri-p x)))))
+
+
+(defun filter-functions::datatype(x)
+  (let ((type-suffix
+	 (when (and (stringp x)
+		    (or (base-tools:string-starts-with x "'")
+			(base-tools:string-starts-with x "\"")))
+	   (let* ((result (base-tools:get-literal x))
+		  (literal-datatype
+		   (when (base-tools:string-starts-with
+			  (getf result :next-string) "^^")
+		     (subseq (getf result :next-string) 2))))
+	     literal-datatype))))
+    (cond (type-suffix type-suffix)
+	  ((integerp x) constants::*xml-integer*)
+	  ((floatp x) constants::*xml-decimal*)
+	  ((numberp x) constants::*xml-double*)
+	  ((stringp x) constants::*xml-string*)
+	  (t (type-of x)))))
+
+
+(defun filter-functions::str(x)
+  ;TODO: implement
+  )
\ 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	Sun Dec 19 16:00:02 2010
@@ -132,8 +132,8 @@
 					;purposes and mustn't be reset
 	      :type List
 	      :initform nil
-	      :documentation "A list of the form that contains the variable
-                              names as string.")
+	      :documentation "A list of that contains the variable
+                              names as strings.")
    (prefixes :initarg :prefixes
 	     :accessor prefixes ;this value is only for internal purposes
 			        ;purposes and mustn't be reset
@@ -154,15 +154,31 @@
 		 :type List
 		 :initform nil
 		 :documentation "Contains a SPARQL-Group that represents
-                                 the entire inner select-where statement."))
+                                 the entire inner select-where statement.")
+   (filters :initarg filters
+	    :accessor filters ;this value is only for internal purposes
+			      ;purposes and mustn't be reset
+	    :type List ;a list of strings
+	    :initform nil
+	    :documentation "Contains strings, each string represents a filter
+                            that was transformed to lisp code and can be evoked
+                            on each triple in the list select-group."))
   (:documentation "This class represents the entire request."))
 
 
 (defgeneric *-p (construct)
   (:documentation "Returns t if the user selected all variables with *.")
   (:method ((construct SPARQL-Query))
-    (and (= (length (variables construct)) 1)
-	 (string= (first (variables construct)) "*"))))
+    (loop for var in (variables construct)
+       when (string= var "*")
+       return t)))
+
+
+(defgeneric add-filter (construct filter)
+  (:documentation "Pushes the filter string to the corresponding list in
+                   the construct.")
+  (:method ((construct SPARQL-Query) (filter String))
+    (push filter (filters construct))))
 
 
 (defmethod variables ((construct SPARQL-Triple))
@@ -236,6 +252,38 @@
       (push variable-name (variables construct)))))
 
 
+(defgeneric invoke-filter (construct filter-string)
+  (:documentation "Invokes the passed filter on the construct that
+                   represents a sparql result.")
+  (:method ((construct SPARQL-Triple) (filter-string String))
+    (dotimes (row-idx (length (subject-result construct)))
+      (let* ((subj-var
+	      (when (variable-p (subject construct))
+		(concatenate 'string "(" (value (subject construct))
+			     " " (elt (subject-result construct) row-idx) ")")))
+	     (pred-var 
+	      (when (variable-p (predicate construct))
+		(concatenate 'string "(" (value (predicate construct))
+			     " " (elt (predicate-result construct) row-idx) ")")))
+	     (obj-var 
+	      (when (variable-p (object construct))
+		(concatenate 'string "(" (value (object construct))
+			     " " (elt (object-result construct) row-idx) ")")))
+	     (var-let
+	      (if (or subj-var pred-var obj-var)
+		  (concatenate 'string "(let (" subj-var pred-var obj-var ")")
+		  "(let ()"))
+	     (expression (concatenate 'string var-let filter-string ")")))
+	
+	))
+    ;TODO: implement
+    ;; *implement a method "invoke-filter(SPARQL-Triple filter-string)" so
+    ;;   that the variables are automatically contained in a let afterwards
+    ;;   the eval function can be called this method should also have a let
+    ;;   with (true t) and (false nil)
+    ))
+
+
 (defgeneric set-results (construct &key revision)
   (:documentation "Calculates the result of a triple and set all the values in
                    the passed object.")
@@ -766,18 +814,16 @@
 (defgeneric result (construct)
   (:documentation "Returns the result of the entire query.")
   (:method ((construct SPARQL-Query))
-    (let ((result-lists (make-result-lists construct)))
-      (reduce-results construct result-lists)
-      (let* ((response-variables
-	      (reverse (if (*-p construct)
-			   (all-variables construct)
-			   (variables construct))))
-	     (cleaned-results (make-result-lists construct)))
-	(map 'list #'(lambda(response-variable)
-		       (list :variable response-variable
-			     :result (variable-intersection response-variable
-							    cleaned-results)))
-	     response-variables)))))
+    (let* ((response-variables
+	    (reverse (if (*-p construct)
+			 (all-variables construct)
+			 (variables construct))))
+	   (cleaned-results (make-result-lists construct)))
+      (map 'list #'(lambda(response-variable)
+		     (list :variable response-variable
+			   :result (variable-intersection response-variable
+							  cleaned-results)))
+	   response-variables))))
 
 
 (defgeneric make-result-lists (construct)
@@ -939,4 +985,10 @@
   (parser-start construct (original-query construct))
   (dolist (triple (select-group construct))
     (set-results triple :revision (revision construct)))
+  ;; filters all entries that are not important for the result
+  ;; => an intersection is invoked
+  (reduce-results construct (make-result-lists construct))
+  (dolist (triple (select-group construct))
+    (dolist (filter (filters construct))
+      (invoke-filter triple filter)))
   construct)
\ No newline at end of file

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Sun Dec 19 16:00:02 2010
@@ -117,18 +117,17 @@
 	    (set-compare-operators construct filter-string-arithmetic-ops))
 	   (filter-string-functions
 	    (set-functions construct filter-string-compare-ops)))
-      (list :next-query next-query
-	    :filter-string (scan-filter-for-deprecated-calls
-			    construct filter-string-functions original-filter-string)))))
+      (add-filter construct
+		  (scan-filter-for-deprecated-calls
+		   construct filter-string-functions original-filter-string))
+      (parse-group construct next-query))))
   ;;TODO: implement
   ;; *implement wrapper functions, also for the operators
-  ;;   it would be nice of the self defined operator functions would be in a
+  ;;   it would be nice when the self defined operator functions would be in a
   ;;   separate packet, e.g. filter-functions, so =, ... would couse no
   ;;   collisions
-  ;; *create and store this filter object => store the created string and implement
-  ;;   a method "invoke-filter(SPARQL-Triple filter-string)" so that the variables
-  ;;   are automatically contained in a letafterwards the eval function can be called
-  ;;   this method should also have a let with (true t) and (false nil)
+  ;; *add ^^datatype to the object-literal-results
+  ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql
 
 
 (defgeneric scan-filter-for-deprecated-calls (construct filter-string
@@ -677,10 +676,8 @@
 		       (push-string current-char result-string))))
 		((or (string= current-char "'")
 		     (string= current-char "\""))
-		 (let* ((sub-str (subseq filter-string idx))
-			(quotation (get-literal-quotation sub-str))
-			(literal
-			 (get-literal (subseq filter-string idx) :quotation quotation)))
+		 (let ((literal
+			(get-literal (subseq filter-string idx))))
 		   (if literal
 		       (progn
 			 (setf idx (- (1- (length filter-string))
@@ -710,7 +707,7 @@
 	     (list :next-query (string-after cleaned-str result)
 		   :scope result)))
 	  ((string-starts-with cleaned-str "\"")
-	   (let ((result (get-literal cleaned-str)))
+	   (let ((result (get-literal cleaned-str :quotation "\"")))
 	     (list :next-query (getf result :next-string)
 		   :scope (getf result :literal))))
 	  ((string-starts-with-digit cleaned-str)
@@ -807,10 +804,7 @@
 	(let ((current-char (subseq str idx (1+ idx))))
 	  (cond ((or (string= "'" current-char)
 		     (string= "\"" current-char))
-		 (let* ((sub-str (subseq str idx))
-			(quotation (get-literal-quotation sub-str))
-			(literal
-			 (get-literal (subseq str idx) :quotation quotation)))
+		 (let ((literal (get-literal (subseq str idx))))
 		   (if literal
 		       (progn
 			 (setf idx (- (1- (length str))
@@ -861,7 +855,8 @@
 		 (push-string current-char filter-string))
 		((or (string= "'" current-char)
 		     (string= "\"" current-char))
-		 (let ((result (get-literal (subseq query-string idx))))
+		 (let ((result
+			(get-literal (subseq query-string idx) :quotation "\"")))
 		   (unless result
 		     (error (make-sparql-parser-condition
 			     (subseq query-string idx)

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Sun Dec 19 16:00:02 2010
@@ -95,7 +95,9 @@
 	(error (make-sparql-parser-condition trimmed-str
 					     (original-query construct) "{")))
       (let ((query-tail (parse-group construct (subseq trimmed-str 1))))
-	;TODO: process query-tail
+	(when (> (length (trim-whitespace query-tail)) 0)
+	  (make-sparql-parser-condition
+	   query-tail (original-query construct) "end of query, solution sequences and modifiers are not supported"))
 	query-tail))))
 
 
@@ -125,7 +127,6 @@
 		     trimmed-str (original-query construct)
 		     "FILTER, BASE, or triple. Grouping is currently no implemented.")))
 	    ((string-starts-with trimmed-str "}") ;ending of this group
-	     ;TODO: invoke filters with all results on construct in initialize :after
 	     (subseq trimmed-str 1))
 	    (t
 	     (parse-triple construct trimmed-str :last-subject last-subject))))))
@@ -249,9 +250,7 @@
 				    literal-value literal-type))))
 	   value))
 	(t ; return the value as a string
-	 (if (stringp literal-value)
-	     literal-value
-	     (write-to-string literal-value)))))
+	 literal-value)))
 	 
 
 (defgeneric separate-literal-lang-or-type (construct query-string)

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Sun Dec 19 16:00:02 2010
@@ -294,49 +294,37 @@
 	 "\"")))
 
 
-(defun get-literal (query-string &key (quotation "\""))
+(defun get-literal (query-string &key (quotation nil))
   "Returns a list of the form (:next-string <string> :literal <string>
    where next-query is the query after the found literal and literal
    is the literal string."
   (declare (String query-string)
-	   (String quotation))
-  (cond ((or (string-starts-with query-string "\"\"\"")
-	     (string-starts-with query-string "'''"))
-	 (let ((literal-end
-		(find-literal-end (subseq query-string 3) (subseq query-string 0 3))))
-	   (when literal-end
-	     (list :next-string (subseq query-string (+ 3 literal-end))
-		   :literal (concatenate 'string quotation
-					 (subseq query-string 3 literal-end)
-					 quotation)))))
-	((or (string-starts-with query-string "\"")
-	     (string-starts-with query-string "'"))
-	 (let ((literal-end
-		(find-literal-end (subseq query-string 1)
-				  (subseq query-string 0 1))))
-	   (when literal-end
-	     (let ((literal
-		    (escape-string (subseq query-string 1 literal-end) "\"")))
-	       (list :next-string (subseq query-string (+ 1 literal-end))
-		     :literal (concatenate 'string quotation literal
-					   quotation))))))))
-
-
-;(defun search-first-ignore-literals (search-strings main-string)
-;  (declare (String main-string)
-;	   (List search-strings))
-;  (let ((first-pos (search-first search-strings main-string)))
-;    (when first-pos
-;      (if (not (in-literal-string-p main-string first-pos))
-;	  first-pos
-;	  (let* ((literal-start (search-first (list "\"" "'") main-string))
-;		 (sub-str (subseq main-string literal-start))
-;		 (literal-result (get-literal sub-str))
-;		 (next-str (getf literal-result :next-string)))
-;	    (let ((next-pos
-;		   (search-first-ignore-literals search-strings next-str)))
-;	      (when next-pos
-;		(+ (- (length main-string) (length next-str)) next-pos))))))))
+	   (type (or Null String) quotation))
+  (let ((local-quotation quotation))
+    (cond ((or (string-starts-with query-string "\"\"\"")
+	       (string-starts-with query-string "'''"))
+	   (unless local-quotation
+	     (setf local-quotation (subseq query-string 0 3)))
+	   (let ((literal-end
+		  (find-literal-end (subseq query-string 3) (subseq query-string 0 3))))
+	     (when literal-end
+	       (list :next-string (subseq query-string (+ 3 literal-end))
+		     :literal (concatenate 'string quotation
+					   (subseq query-string 3 literal-end)
+					   quotation)))))
+	  ((or (string-starts-with query-string "\"")
+	       (string-starts-with query-string "'"))
+	   (unless local-quotation
+	     (setf local-quotation (subseq query-string 0 1)))
+	   (let ((literal-end
+		  (find-literal-end (subseq query-string 1)
+				    (subseq query-string 0 1))))
+	     (when literal-end
+	       (let ((literal
+		      (escape-string (subseq query-string 1 literal-end) "\"")))
+		 (list :next-string (subseq query-string (+ 1 literal-end))
+		       :literal (concatenate 'string local-quotation literal
+					     local-quotation)))))))))
 
 
 (defun search-first-ignore-literals (search-strings main-string &key from-end)

Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd	(original)
+++ trunk/src/isidorus.asd	Sun Dec 19 16:00:02 2010
@@ -1,4 +1,3 @@
-;;-*- mode: lisp -*-
 ;;+-----------------------------------------------------------------------------
 ;;+  Isidorus
 ;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
@@ -42,8 +41,9 @@
 			:depends-on ("constants" "base-tools"))
 	       (:module "TM-SPARQL"
 			:components ((:file "sparql")
+				     (:file "filter_wrappers")
 				     (:file "sparql_filter"
-					    :depends-on ("sparql"))
+					    :depends-on ("sparql" "filter_wrappers"))
 				     (:file "sparql_parser"
 					    :depends-on ("sparql" "sparql_filter")))
 			:depends-on ("constants" "base-tools" "model"))



From lgiessmann at common-lisp.net  Sun Dec 19 22:48:03 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sun, 19 Dec 2010 17:48:03 -0500
Subject: [isidorus-cvs] r377 - trunk/src/TM-SPARQL
Message-ID: <E1PUS2t-0007qo-1m@common-lisp.net>

Author: lgiessmann
Date: Sun Dec 19 17:48:02 2010
New Revision: 377

Log:
TM-SPARQL: implemented the handling of filters

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp

Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp	(original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Sun Dec 19 17:48:02 2010
@@ -142,5 +142,10 @@
 
 
 (defun filter-functions::str(x)
-  ;TODO: implement
-  )
\ No newline at end of file
+  (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

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Sun Dec 19 17:48:02 2010
@@ -256,32 +256,35 @@
   (:documentation "Invokes the passed filter on the construct that
                    represents a sparql result.")
   (:method ((construct SPARQL-Triple) (filter-string String))
-    (dotimes (row-idx (length (subject-result construct)))
-      (let* ((subj-var
-	      (when (variable-p (subject construct))
-		(concatenate 'string "(" (value (subject construct))
-			     " " (elt (subject-result construct) row-idx) ")")))
-	     (pred-var 
-	      (when (variable-p (predicate construct))
-		(concatenate 'string "(" (value (predicate construct))
-			     " " (elt (predicate-result construct) row-idx) ")")))
-	     (obj-var 
-	      (when (variable-p (object construct))
-		(concatenate 'string "(" (value (object construct))
-			     " " (elt (object-result construct) row-idx) ")")))
-	     (var-let
-	      (if (or subj-var pred-var obj-var)
-		  (concatenate 'string "(let (" subj-var pred-var obj-var ")")
-		  "(let ()"))
-	     (expression (concatenate 'string var-let filter-string ")")))
-	
-	))
-    ;TODO: implement
-    ;; *implement a method "invoke-filter(SPARQL-Triple filter-string)" so
-    ;;   that the variables are automatically contained in a let afterwards
-    ;;   the eval function can be called this method should also have a let
-    ;;   with (true t) and (false nil)
-    ))
+    (let ((results nil)) ;a list of the form (:subject x :predicate y :object z)
+      (dotimes (row-idx (length (subject-result construct)))
+	(let* ((subj-var
+		(when (variable-p (subject construct))
+		  (concatenate 'string "(" (value (subject construct))
+			       " " (elt (subject-result construct) row-idx) ")")))
+	       (pred-var 
+		(when (variable-p (predicate construct))
+		  (concatenate 'string "(" (value (predicate construct))
+			       " " (elt (predicate-result construct) row-idx) ")")))
+	       (obj-var 
+		(when (variable-p (object construct))
+		  (concatenate 'string "(" (value (object construct))
+			       " " (elt (object-result construct) row-idx) ")")))
+	       (var-let
+		(concatenate 'string "(let ((true t) (false nil)"
+			     subj-var pred-var obj-var ")"))
+	       (expression (concatenate 'string var-let filter-string ")")))
+	  (when (eval (read-from-string expression))
+	    (push (list :subject (elt (subject-result construct) row-idx)
+			:predicate (elt (predicate-result construct) row-idx)
+			:object (elt (object-result construct) row-idx))
+		  results))))
+      (setf (subject-result construct)
+	    (map 'list #'(lambda(result) (getf result :subject)) results))
+      (setf (predicate-result construct)
+	    (map 'list #'(lambda(result) (getf result :predicate)) results))
+      (setf (object-result construct)
+	    (map 'list #'(lambda(result) (getf result :object)) results)))))
 
 
 (defgeneric set-results (construct &key revision)



From lgiessmann at common-lisp.net  Mon Dec 20 16:25:54 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 20 Dec 2010 11:25:54 -0500
Subject: [isidorus-cvs] r378 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1PUiYc-0004pC-5r@common-lisp.net>

Author: lgiessmann
Date: Mon Dec 20 11:25:53 2010
New Revision: 378

Log:
TM-SPARQL: adapted some unit-tests to the latest changes; fixed a bug when calculating the final result

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Mon Dec 20 11:25:53 2010
@@ -271,9 +271,14 @@
 		  (concatenate 'string "(" (value (object construct))
 			       " " (elt (object-result construct) row-idx) ")")))
 	       (var-let
-		(concatenate 'string "(let ((true t) (false nil)"
+		(concatenate 'string "(let ((true t) (false nil) "
 			     subj-var pred-var obj-var ")"))
-	       (expression (concatenate 'string var-let filter-string ")")))
+	       (expression
+		(concatenate 'string var-let "(cl:handler-case "
+			     filter-string
+			     "(exception:sparql-parser-error (err) "
+			     "(cl:in-package :cl-user) "
+			     "(error err)))")))
 	  (when (eval (read-from-string expression))
 	    (push (list :subject (elt (subject-result construct) row-idx)
 			:predicate (elt (predicate-result construct) row-idx)
@@ -945,11 +950,16 @@
       (when var-elem
 	(let* ((rows-to-hold
 		(remove-null
-		 (map 'list #'(lambda(val)
-				(if (stringp val)
-				    (position val var-elem :test #'string=)
-				    (position val var-elem)))
-		      dont-touch-values)))
+		 (map 'list #'(lambda(res)
+				(when (cond
+					((stringp res)
+					 (find res dont-touch-values :test #'string=))
+					((numberp res)
+					 (find res dont-touch-values :test #'=))
+					(t
+					 (find res dont-touch-values)))
+				  (position res var-elem)))
+		      var-elem)))
 	       (new-result-list
 		(map 'list
 		     #'(lambda(row-idx)

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Mon Dec 20 11:25:53 2010
@@ -122,10 +122,6 @@
 		   construct filter-string-functions original-filter-string))
       (parse-group construct next-query))))
   ;;TODO: implement
-  ;; *implement wrapper functions, also for the operators
-  ;;   it would be nice when the self defined operator functions would be in a
-  ;;   separate packet, e.g. filter-functions, so =, ... would couse no
-  ;;   collisions
   ;; *add ^^datatype to the object-literal-results
   ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Mon Dec 20 11:25:53 2010
@@ -37,7 +37,8 @@
 	   :test-set-*-and-/-operators
 	   :test-set-+-and---operators
 	   :test-set-compare-operators
-	   :test-set-functions))
+	   :test-set-functions
+	   :test-module-1))
 
 
 (in-package :sparql-test)
@@ -472,7 +473,7 @@
 			 (string= obj-1 "<http://some.where/psis/der_zauberlehrling>")))
 		 (is (or (string= subj-2 "<http://some.where/psis/author/goethe>")
 			 (string= subj-2 "<http://some.where/psis/persons/goethe>")))
-		 (is (string= pred-1 "<http://psi.topicmaps.org/iso13250/model/type>"))
+		 (is (string= pred-1 "<http://psi.topicmaps.org/iso13250/model/instance>"))
 		 (is (or (string= obj-2 "<http://some.where/psis/poem/zauberlehrling>")
 			 (string= obj-2 "<http://some.where/psis/der_zauberlehrling>"))))
 		(t
@@ -867,7 +868,7 @@
 	(is (= (length (tm-sparql::subject-result
 			(first (tm-sparql::select-group q-obj-3)))) 0))
 	(is (= (length (tm-sparql::subject-result
-			(second (tm-sparql::select-group q-obj-3)))) 1))
+			(second (tm-sparql::select-group q-obj-3)))) 0))
 	(is (or (string= "<http://some.where/psis/author/goethe>"
 			 (first (tm-sparql::subject-result
 				 (first (tm-sparql::select-group q-obj-1)))))
@@ -922,18 +923,12 @@
 			  (first (tm-sparql::select-group q-obj-3)))))
 	(is-false (first (tm-sparql::object-result
 			  (first (tm-sparql::select-group q-obj-3)))))
-	(is (or (string= "<http://some.where/psis/author/goethe>"
-			 (first (tm-sparql::subject-result
-				 (second (tm-sparql::select-group q-obj-3)))))
-		(string= "<http://some.where/psis/persons/goethe>"
-			 (first (tm-sparql::subject-result
-				 (second (tm-sparql::select-group q-obj-3)))))))
-	(is (string= "<http://some.where/base-psis/last-name>"
-		     (first (tm-sparql::predicate-result
-			     (second (tm-sparql::select-group q-obj-3))))))
-	(is (string= "von Goethe"
-		     (first (tm-sparql::object-result
-			     (second (tm-sparql::select-group q-obj-3))))))))))
+	(is-false (first (tm-sparql::subject-result
+			  (second (tm-sparql::select-group q-obj-3)))))
+	(is-false (first (tm-sparql::predicate-result
+			  (second (tm-sparql::select-group q-obj-3)))))
+	(is-false (first (tm-sparql::object-result
+			  (second (tm-sparql::select-group q-obj-3)))))))))
 
 
 (test test-result
@@ -1528,7 +1523,43 @@
 		 "(or(progn(DATATYPE?var3))(progn(isLITERAL(=(one+?var1)(one-?var2)))))"))
     (is (string= (string-replace result-5-6 " " "")
 		 "(or(progn(DATATYPE?var3))(progn(progn(isLITERAL(=(one+?var1)(one-?var2))))))"))))
-	 
+
+
+;(test test-module-1
+;  "Tests the entire module."
+;  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+;    (with-revision 0
+;      (let* ((query-1
+;	      "BASE <http://some.where/psis/poem/>
+;              SELECT $subject ?predicate WHERE{
+;               ?subject $predicate <zauberlehrling> .
+;               FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}")
+;	     (query-2 "SELECT ?object ?subject WHERE{
+;                        <http://some.where/psis/author/goethe> ?prediate ?object .
+;                        FILTER (isLITERAL(?object) &&
+;                                DATATYPE(?object) =
+;                                 'http://www.w3.org/2001/XMLSchema#string')}")
+;	     (query-3 "SELECT ?object ?subject WHERE{
+;                        <http://some.where/psis/author/goethe> ?prediate ?object .
+;                        FILTER (notAllowed(?subject)}")
+;	     (query-4 "SELECT ?object ?subject WHERE{
+;                        <http://some.where/psis/author/goethe> ?prediate ?object .
+;                        FILTER ((notAllowed ?subject))}")
+;	     (query-5 "SELECT ?object ?subject WHERE{
+;                        <http://some.where/psis/author/goethe> ?prediate ?object .
+;                        FILTER(?a && (?b || ?c)}")
+;	     (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))
+;	     (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)))
+;	(is-true q-obj-1)
+;	(is-true q-obj-2)
+;	(signals excpetions-sparql-parser-error
+;	  (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))
+;	(signals excpetions-sparql-parser-error
+;	  (make-instance 'TM-SPARQL:SPARQL-Query :query query-4))
+;	(signals excpetions-sparql-parser-error
+;	  (make-instance 'TM-SPARQL:SPARQL-Query :query query-5))
+;	;;TODO: implement
+;	))))
     
 
 (defun run-sparql-tests ()



From lgiessmann at common-lisp.net  Mon Dec 20 18:28:01 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 20 Dec 2010 13:28:01 -0500
Subject: [isidorus-cvs] r379 - trunk/src/TM-SPARQL
Message-ID: <E1PUkSn-00044e-Cg@common-lisp.net>

Author: lgiessmann
Date: Mon Dec 20 13:28:01 2010
New Revision: 379

Log:
TM-SPARQL: fixed a bug when invoking filters => all functions are explicit wrapped in the filter-functions package by using the prefix 'filter-functions::' in the filter stirng.

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp

Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp	(original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Mon Dec 20 13:28:01 2010
@@ -9,7 +9,8 @@
 
 
 (defpackage :filter-functions
-  (:use :base-tools :constants :tm-sparql))
+  (:use :base-tools :constants :tm-sparql)
+  (:import-from :cl progn handler-case let))
 
 
 (defun filter-functions::not(x)

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Mon Dec 20 13:28:01 2010
@@ -252,33 +252,50 @@
       (push variable-name (variables construct)))))
 
 
+(defgeneric generate-let-variable-string (construct value)
+  (:documentation "Returns a list if the form (:string <var-string>
+                  :variable-names (<?var-name-as-string>
+                  <$var-name-as-string>)).")
+  (:method ((construct SPARQL-Triple-Elem) value)
+    (when (variable-p construct)
+      (let* ((var-value (write-to-string value))
+	     (var-name (value construct))
+	     (lisp-str
+	      (concatenate 'string "(?" var-name " " var-value ")"
+			   "($" var-name " " var-value ")"))
+	     (vars
+	      (concatenate 'string "?" var-name " $" var-name)))
+	(list :string lisp-str
+	      :variable-names vars)))))
+
+
 (defgeneric invoke-filter (construct filter-string)
   (:documentation "Invokes the passed filter on the construct that
                    represents a sparql result.")
   (:method ((construct SPARQL-Triple) (filter-string String))
     (let ((results nil)) ;a list of the form (:subject x :predicate y :object z)
       (dotimes (row-idx (length (subject-result construct)))
-	(let* ((subj-var
-		(when (variable-p (subject construct))
-		  (concatenate 'string "(" (value (subject construct))
-			       " " (elt (subject-result construct) row-idx) ")")))
-	       (pred-var 
-		(when (variable-p (predicate construct))
-		  (concatenate 'string "(" (value (predicate construct))
-			       " " (elt (predicate-result construct) row-idx) ")")))
-	       (obj-var 
-		(when (variable-p (object construct))
-		  (concatenate 'string "(" (value (object construct))
-			       " " (elt (object-result construct) row-idx) ")")))
-	       (var-let
-		(concatenate 'string "(let ((true t) (false nil) "
-			     subj-var pred-var obj-var ")"))
+	(let* ((subj-elem
+		(generate-let-variable-string
+		 (subject construct) (elt (subject-result construct) row-idx)))
+	       (pred-elem
+		(generate-let-variable-string
+		 (predicate construct) (elt (predicate-result construct) row-idx)))
+	       (obj-elem
+		(generate-let-variable-string
+		 (object construct) (elt (object-result construct) row-idx)))
 	       (expression
-		(concatenate 'string var-let "(cl:handler-case "
-			     filter-string
-			     "(exception:sparql-parser-error (err) "
-			     "(cl:in-package :cl-user) "
-			     "(error err)))")))
+		(concatenate 'string
+			     "(let* ((true t)(false nil)"
+			     (getf subj-elem :string)
+			     (getf pred-elem :string)
+			     (getf obj-elem :string)
+			     "(result " filter-string "))"
+			     "(declare (ignorable true false "
+			     (getf subj-elem :variable-names) " "
+			     (getf pred-elem :variable-names) " "
+			     (getf obj-elem :variable-names) "))"
+			     "result)")))
 	  (when (eval (read-from-string expression))
 	    (push (list :subject (elt (subject-result construct) row-idx)
 			:predicate (elt (predicate-result construct) row-idx)

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Mon Dec 20 13:28:01 2010
@@ -128,20 +128,27 @@
 
 (defgeneric scan-filter-for-deprecated-calls (construct filter-string
 							original-filter)
-  (:documentation "Returns the passed filter-string or throws a
-                   sparql-parser-error of there is an unallowed
-                   function call.")
+  (:documentation "Returns the passed filter-string where all functions
+                   are explicit wrapped in the filter-functions package
+                   or throws a sparql-parser-error of there is an
+                   unallowed function call.")
   (:method ((construct SPARQL-Query) (filter-string String)
 	    (original-filter String))
-    (dotimes (idx (length filter-string) filter-string)
-      (when-do fun-name (return-function-name (subseq filter-string idx))
-	       (unless (string-starts-with-one-of fun-name *supported-functions*)
+    (let ((result ""))
+      (dotimes (idx (length filter-string) result)
+	(let ((fun-name (return-function-name (subseq filter-string idx))))
+	  (cond ((not fun-name)
+		 (push-string (subseq filter-string idx (1+ idx)) result))
+		((string-starts-with-one-of fun-name *allowed-filter-calls*)
+		 (push-string "(filter-functions::" result)
+		 (push-string fun-name result)
+		 (incf idx (length fun-name)))
+		(t
 		 (error 
 		  (make-condition
 		   'exceptions:sparql-parser-error
-		   :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the depricated function ~a!"
-				    filter-string original-filter fun-name))))))))
-	       
+		   :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the deprecated function ~a!"
+				    filter-string original-filter fun-name))))))))))
 
 
 (defun return-function-name (filter-string)

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Mon Dec 20 13:28:01 2010
@@ -117,7 +117,7 @@
 		     trimmed-str (original-query construct)
 		     "FILTER, BASE, or triple. Grouping is currently no implemented.")))
 	    ((string-starts-with trimmed-str "FILTER")
-	     (parse-filter (string-after trimmed-str "FILTER") construct))
+	     (parse-filter construct (string-after trimmed-str "FILTER")))
 	    ((string-starts-with trimmed-str "OPTIONAL")
 	     (error (make-sparql-parser-condition
 		     trimmed-str (original-query construct)



From lgiessmann at common-lisp.net  Mon Dec 20 19:14:56 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 20 Dec 2010 14:14:56 -0500
Subject: [isidorus-cvs] r380 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1PUlCC-0006m5-6k@common-lisp.net>

Author: lgiessmann
Date: Mon Dec 20 14:14:55 2010
New Revision: 380

Log:
TM-SPARQL: added some unit-tests that cover the main function 'initialize-instance :around' and 'result'

Modified:
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Mon Dec 20 14:14:55 2010
@@ -124,6 +124,7 @@
   ;;TODO: implement
   ;; *add ^^datatype to the object-literal-results
   ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql
+  ;; *implement str correctly
 
 
 (defgeneric scan-filter-for-deprecated-calls (construct filter-string

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Mon Dec 20 14:14:55 2010
@@ -1525,41 +1525,80 @@
 		 "(or(progn(DATATYPE?var3))(progn(progn(isLITERAL(=(one+?var1)(one-?var2))))))"))))
 
 
-;(test test-module-1
-;  "Tests the entire module."
-;  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
-;    (with-revision 0
-;      (let* ((query-1
-;	      "BASE <http://some.where/psis/poem/>
-;              SELECT $subject ?predicate WHERE{
-;               ?subject $predicate <zauberlehrling> .
-;               FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}")
-;	     (query-2 "SELECT ?object ?subject WHERE{
-;                        <http://some.where/psis/author/goethe> ?prediate ?object .
-;                        FILTER (isLITERAL(?object) &&
-;                                DATATYPE(?object) =
-;                                 'http://www.w3.org/2001/XMLSchema#string')}")
-;	     (query-3 "SELECT ?object ?subject WHERE{
-;                        <http://some.where/psis/author/goethe> ?prediate ?object .
-;                        FILTER (notAllowed(?subject)}")
-;	     (query-4 "SELECT ?object ?subject WHERE{
-;                        <http://some.where/psis/author/goethe> ?prediate ?object .
-;                        FILTER ((notAllowed ?subject))}")
-;	     (query-5 "SELECT ?object ?subject WHERE{
-;                        <http://some.where/psis/author/goethe> ?prediate ?object .
-;                        FILTER(?a && (?b || ?c)}")
-;	     (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))
-;	     (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)))
-;	(is-true q-obj-1)
-;	(is-true q-obj-2)
-;	(signals excpetions-sparql-parser-error
-;	  (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))
-;	(signals excpetions-sparql-parser-error
-;	  (make-instance 'TM-SPARQL:SPARQL-Query :query query-4))
-;	(signals excpetions-sparql-parser-error
-;	  (make-instance 'TM-SPARQL:SPARQL-Query :query query-5))
-;	;;TODO: implement
-;	))))
+(test test-module-1
+  "Tests the entire module."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let* ((query-1
+	      "BASE <http://some.where/psis/poem/>
+              SELECT $subject ?predicate WHERE{
+               ?subject $predicate <zauberlehrling> .
+               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) &&
+                                DATATYPE(?object) =
+                                 'http://www.w3.org/2001/XMLSchema#string')}")
+	     (query-3 "SELECT ?object ?subject WHERE{
+                        <http://some.where/psis/author/goethe> ?predicate ?object .
+                        FILTER (notAllowed(?subject)}")
+	     (query-4 "SELECT ?object ?predicate WHERE{
+                        <http://some.where/psis/author/goethe> ?predicate ?object .
+                        FILTER ((notAllowed( ?predicate)))}")
+	     (query-5 "SELECT ?object ?subject WHERE{
+                        <http://some.where/psis/author/goethe> ?predicate ?object .
+                        FILTER(?a && (?b || ?c)}")
+	     (result-1
+	      (tm-sparql:result
+	       (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)))
+	     (result-2 
+	      (tm-sparql:result
+	       (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))))
+	(is-true result-1)
+	(is-true result-2)
+	(signals exceptions:sparql-parser-error
+	  (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-3)))
+	(signals exceptions:sparql-parser-error
+	  (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-4)))
+	(signals exceptions:sparql-parser-error
+	  (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-5)))
+	(is (= (length result-1) 2))
+	(if (string= (getf (first result-1) :variable) "subject")
+	    (progn
+	      (is (= (length (getf (first result-1) :result)) 1))
+	      (is (string= (first (getf (first result-1) :result))
+			   "<http://some.where/psis/author/goethe>"))
+	      (is (string= (getf (second result-1) :variable) "predicate"))
+	      (is (= (length (getf (second result-1) :result)) 1))
+	      (is (string= (first (getf (second result-1) :result))
+			   "<http://some.where/base-psis/written>")))
+	    (progn
+	      (is (= (length (getf (second result-1) :result)) 1))
+	      (is (string= (first (getf (second result-1) :result))
+			   "<http://some.where/psis/author/goethe>"))
+	      (is (string= (getf (first result-1) :variable) "predicate"))
+	      (is (= (length (getf (first result-1) :result)) 1))
+	      (is (string= (first (getf (first result-1) :result))
+			   "<http://some.where/base-psis/written>"))))
+	(if (string= (getf (first result-2) :variable) "subject")
+	    (progn 
+	      (is (= (length (getf (first result-2) :result)) 0))
+	      (is (string= (getf (second result-2) :variable) "object"))
+	      (is (= (length (getf (second result-2) :result)) 3))
+	      (is-false (set-exclusive-or
+			 (getf (second result-2) :result)
+			 (list "Johann Wolfgang" "von Goethe"
+			       "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")
+			 :test #'string=)))
+	    (progn 
+	      (is (= (length (getf (second result-2) :result)) 0))
+	      (is (string= (getf (first result-2) :variable) "object"))
+	      (is (= (length (getf (first result-2) :result)) 3))
+	      (is-false (set-exclusive-or
+			 (getf (first result-2) :result)
+			 (list "Johann Wolfgang" "von Goethe"
+			       "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")
+			 :test #'string=))))))))
     
 
 (defun run-sparql-tests ()



From lgiessmann at common-lisp.net  Mon Dec 20 20:47:48 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 20 Dec 2010 15:47:48 -0500
Subject: [isidorus-cvs] r381 - in trunk/src: . TM-SPARQL
Message-ID: <E1PUme4-0004eo-AS@common-lisp.net>

Author: lgiessmann
Date: Mon Dec 20 15:47:48 2010
New Revision: 381

Log:
TM-SPARQL: fixed the type-handling in FILTERs when there is given something like 'xyz'^^anyType

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/isidorus.asd

Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp	(original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Mon Dec 20 15:47:48 2010
@@ -13,49 +13,84 @@
   (:import-from :cl progn handler-case let))
 
 
+(defun filter-functions::normalize-value (value)
+  "Returns the normalized value, i.e. if a literal
+   is passed as '12'^^xsd:integer 12 is returned."
+  (cond ((not (stringp value))
+	 value)
+	((or (base-tools:string-starts-with value "'")
+	     (base-tools:string-starts-with value "\""))
+	 (let* ((literal-result (tm-sparql::get-literal value))
+		(literal-value
+		 (cond ((or (base-tools:string-starts-with
+			     (getf literal-result :literal) "\"\"\"")
+			    (base-tools:string-starts-with
+			     (getf literal-result :literal) "'''"))
+			(subseq (getf literal-result :literal) 3
+				(- (length (getf literal-result :literal)) 3)))
+		       (t
+			(subseq (getf literal-result :literal) 1
+				(- (length (getf literal-result :literal)) 1)))))
+		(given-datatype
+		 (when (base-tools:string-starts-with
+			(getf literal-result :next-string) "^^")
+		   (subseq (getf literal-result :next-string) 2))))
+	   (tm-sparql::cast-literal literal-value given-datatype)))
+	(t
+	 value)))
+
+
 (defun filter-functions::not(x)
-  (not x))
+  (not (filter-functions::normalize-value x)))
 
 
 (defun filter-functions::one+(x)
-  (1+ x))
+  (1+ (filter-functions::normalize-value x)))
 
 
 (defun filter-functions::one-(x)
-  (1- x))
+  (1- (filter-functions::normalize-value x)))
 
 
 (defun filter-functions::+(x y)
-  (+ x y))
+  (+ (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
 
 
 (defun filter-functions::-(x y)
-  (- x y))
+  (- (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
 
 
 (defun filter-functions::*(x y)
-  (* x y))
+  (* (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
 
 
 (defun filter-functions::/(x y)
-  (/ x y))
+  (/ (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
 
 
 (defun filter-functions::or(x y)
-  (or x y))
+  (or (filter-functions::normalize-value x)
+      (filter-functions::normalize-value y)))
 
 
 (defun filter-functions::and(x y)
-  (and x y))
+  (and (filter-functions::normalize-value x)
+       (filter-functions::normalize-value y)))
 
 
 (defun filter-functions::=(x y)
-  (cond ((and (stringp x) (stringp y))
-	 (string= x y))
-	((and (numberp x)( numberp y))
-	 (= x y))
-	(t
-	 (eql x y))))
+  (let ((local-x (filter-functions::normalize-value x))
+	(local-y (filter-functions::normalize-value y)))
+    (cond ((and (stringp local-x) (stringp local-y))
+	   (string= local-x local-y))
+	  ((and (numberp local-x)( numberp local-y))
+	   (= local-x local-y))
+	  (t
+	   (eql local-x local-y)))))
 
 
 (defun filter-functions::!=(x y)
@@ -64,14 +99,16 @@
 
 
 (defun filter-functions::<(x y)
-  (cond ((and (numberp x) (numberp y))
-	 (< x y))
-	((and (stringp x) (stringp y))
-	 (string< x y))
-	((and (typep x 'Boolean) (typep y 'Boolean))
-	 (and (not x) y))
-	(t
-	 nil)))
+  (let ((local-x (filter-functions::normalize-value x))
+	(local-y (filter-functions::normalize-value y)))
+    (cond ((and (numberp local-x) (numberp local-y))
+	   (< local-x local-y))
+	  ((and (stringp local-x) (stringp local-y))
+	   (string< local-x local-y))
+	  ((and (typep local-x 'Boolean) (typep local-y 'Boolean))
+	   (and (not local-x) local-y))
+	  (t
+	   nil))))
 
 
 (defun filter-functions::>(x y)
@@ -92,18 +129,20 @@
 	   
 
 (defun filter-functions::regex(str pattern &optional flags)
-  (declare (Ignorable flags))
-  (let* ((case-insensitive (when (find #\i flags) t))
-	 (multi-line (when (find #\m flags) t))
-	 (single-line (when (find #\s flags) t))
+  (let* ((local-flags (filter-functions::normalize-value flags))
+	 (case-insensitive (when (find #\i local-flags) t))
+	 (multi-line (when (find #\m local-flags) t))
+	 (single-line (when (find #\s local-flags) t))
       	 (local-pattern
-	  (if (find #\x flags)
+	  (if (find #\x local-flags)
 	      (base-tools:string-replace
 	       (base-tools:string-replace
 		(base-tools:string-replace
-		 (base-tools:string-replace pattern (string #\newline) "")
+		 (base-tools:string-replace
+		  (filter-functions::normalize-value pattern)
+		  (string #\newline) "")
 		 (string #\tab) "") (string #\cr) "") " " "")
-	      pattern))
+	      (filter-functions::normalize-value pattern)))
 	 (scanner
 	  (ppcre:create-scanner local-pattern
 				:case-insensitive-mode case-insensitive

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Mon Dec 20 15:47:48 2010
@@ -1010,6 +1010,42 @@
       values)))
 
 
+(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 (and (string/= literal-value "false")
+		    (string/= literal-value "true"))
+	   (error (make-condition
+		   'sparql-parser-error
+		   :message (format nil "Could not cast from ~a to ~a"
+				    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))
+	(t ; return the value as a string
+	 literal-value)))
+
+
 (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args)
   (declare (ignorable args))
   (parser-start construct (original-query construct))

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Mon Dec 20 15:47:48 2010
@@ -121,10 +121,6 @@
 		  (scan-filter-for-deprecated-calls
 		   construct filter-string-functions original-filter-string))
       (parse-group construct next-query))))
-  ;;TODO: implement
-  ;; *add ^^datatype to the object-literal-results
-  ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql
-  ;; *implement str correctly
 
 
 (defgeneric scan-filter-for-deprecated-calls (construct filter-string

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Mon Dec 20 15:47:48 2010
@@ -217,42 +217,6 @@
 	    :value (cast-literal l-value l-type)))))
 
 
-(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 (and (string/= literal-value "false")
-		    (string/= literal-value "true"))
-	   (error (make-condition
-		   'sparql-parser-error
-		   :message (format nil "Could not cast from ~a to ~a"
-				    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))
-	(t ; return the value as a string
-	 literal-value)))
-	 
-
 (defgeneric separate-literal-lang-or-type (construct query-string)
   (:documentation "A helper function that returns (:next-query string
                    :lang string :type string). Only one of :lang and

Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd	(original)
+++ trunk/src/isidorus.asd	Mon Dec 20 15:47:48 2010
@@ -41,7 +41,8 @@
 			:depends-on ("constants" "base-tools"))
 	       (:module "TM-SPARQL"
 			:components ((:file "sparql")
-				     (:file "filter_wrappers")
+				     (:file "filter_wrappers"
+					    :depends-on ("sparql"))
 				     (:file "sparql_filter"
 					    :depends-on ("sparql" "filter_wrappers"))
 				     (:file "sparql_parser"



From lgiessmann at common-lisp.net  Tue Dec 21 20:20:37 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 21 Dec 2010 15:20:37 -0500
Subject: [isidorus-cvs] r382 - trunk/src/base-tools
Message-ID: <E1PV8hJ-0007H4-3S@common-lisp.net>

Author: lgiessmann
Date: Tue Dec 21 15:20:36 2010
New Revision: 382

Log:
TM-SPARQL: fixed a bug in search-firstunclosed-paranthesis when the string contains string-literals; added the macro concat which is a shortcut for concatenate 'string ... 

Modified:
   trunk/src/base-tools/base-tools.lisp

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Tue Dec 21 15:20:36 2010
@@ -11,6 +11,7 @@
   (:use :cl)
   (:nicknames :tools)
   (:export :push-string
+	   :concat
 	   :when-do
 	   :string-replace
 	   :remove-null
@@ -64,6 +65,10 @@
   `(setf ,place (concatenate 'string ,place ,obj)))
 
 
+(defmacro concat (&rest strings)
+  `(concatenate 'string , at strings))
+
+
 (defmacro when-do (result-bounding condition-statement do-with-result)
   "Executes the first statement and stores its result in the variable result.
    If result isn't nil the second statement is called.
@@ -449,15 +454,14 @@
 (defun search-first-unclosed-paranthesis (str &key ignore-literals)
   "Returns the idx of the first ( that is not closed, the search is
    started from the end of the string.
-   If ignore-literals is set to t all mparanthesis that are within
+   If ignore-literals is set to t all paranthesis that are within
    \", \"\"\", ' and ''' are ignored."
   (declare (String str)
 	   (Boolean ignore-literals))
-  (let ((r-str (reverse str))
-	(open-brackets 0)
+  (let ((open-brackets 0)
 	(result-idx nil))
-    (dotimes (idx (length r-str))
-      (let ((current-char (subseq r-str idx (1+ idx))))
+    (do ((idx (1- (length str)))) ((< idx 0))
+      (let ((current-char (subseq str idx (1+ idx))))
 	(cond ((string= current-char ")")
 	       (when (or ignore-literals
 			 (not (in-literal-string-p str idx)))
@@ -468,9 +472,9 @@
 		 (incf open-brackets)
 		 (when (> open-brackets 0)
 		   (setf result-idx idx)
-		   (setf idx (length r-str))))))))
-    (when result-idx
-      (- (length str) (1+ result-idx)))))
+		   (setf idx 0)))))
+	(decf idx)))
+    result-idx))
 
 
 (defun search-first-unopened-paranthesis (str &key ignore-literals)



From lgiessmann at common-lisp.net  Tue Dec 21 22:57:58 2010
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 21 Dec 2010 17:57:58 -0500
Subject: [isidorus-cvs] r383 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1PVB9a-0001IF-67@common-lisp.net>

Author: lgiessmann
Date: Tue Dec 21 17:57:57 2010
New Revision: 383

Log:
TM-SPARQL: fixed a fundamental bug => if a filter uses more than one variable from different triples => currently there is created a cross product of all variable-results in a select-group, afterwards the values that always evaluates to false are removed from the main result.

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.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	Tue Dec 21 17:57:57 2010
@@ -129,11 +129,12 @@
 	   
 
 (defun filter-functions::regex(str pattern &optional flags)
-  (let* ((local-flags (filter-functions::normalize-value flags))
+  (let* ((local-str (filter-functions::normalize-value str))
+	 (local-flags (filter-functions::normalize-value flags))
 	 (case-insensitive (when (find #\i local-flags) t))
 	 (multi-line (when (find #\m local-flags) t))
 	 (single-line (when (find #\s local-flags) t))
-      	 (local-pattern
+	 (local-pattern
 	  (if (find #\x local-flags)
 	      (base-tools:string-replace
 	       (base-tools:string-replace
@@ -148,7 +149,7 @@
 				:case-insensitive-mode case-insensitive
 				:multi-line-mode multi-line
 				:single-line-mode single-line)))
-    (ppcre:scan scanner str)))
+    (ppcre:scan scanner local-str)))
 
 
 (defun filter-functions::bound(x)

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Tue Dec 21 17:57:57 2010
@@ -234,12 +234,10 @@
                    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) ":"))
+       when (string-starts-with string-with-prefix (concat (getf entry :label) ":"))
        return (concatenate-uri
 	       (getf entry :value)
-	       (string-after string-with-prefix
-			     (concatenate 'string (getf entry :label) ":"))))))
+	       (string-after string-with-prefix (concat (getf entry :label) ":"))))))
 
 
 (defgeneric add-variable (construct variable-name)
@@ -252,61 +250,173 @@
       (push variable-name (variables construct)))))
 
 
-(defgeneric generate-let-variable-string (construct value)
-  (:documentation "Returns a list if the form (:string <var-string>
-                  :variable-names (<?var-name-as-string>
-                  <$var-name-as-string>)).")
-  (:method ((construct SPARQL-Triple-Elem) value)
-    (when (variable-p construct)
-      (let* ((var-value (write-to-string value))
-	     (var-name (value construct))
-	     (lisp-str
-	      (concatenate 'string "(?" var-name " " var-value ")"
-			   "($" var-name " " var-value ")"))
-	     (vars
-	      (concatenate 'string "?" var-name " $" var-name)))
-	(list :string lisp-str
-	      :variable-names vars)))))
-
-
-(defgeneric invoke-filter (construct filter-string)
-  (:documentation "Invokes the passed filter on the construct that
-                   represents a sparql result.")
-  (:method ((construct SPARQL-Triple) (filter-string String))
-    (let ((results nil)) ;a list of the form (:subject x :predicate y :object z)
-      (dotimes (row-idx (length (subject-result construct)))
-	(let* ((subj-elem
-		(generate-let-variable-string
-		 (subject construct) (elt (subject-result construct) row-idx)))
-	       (pred-elem
-		(generate-let-variable-string
-		 (predicate construct) (elt (predicate-result construct) row-idx)))
-	       (obj-elem
-		(generate-let-variable-string
-		 (object construct) (elt (object-result construct) row-idx)))
-	       (expression
-		(concatenate 'string
-			     "(let* ((true t)(false nil)"
-			     (getf subj-elem :string)
-			     (getf pred-elem :string)
-			     (getf obj-elem :string)
-			     "(result " filter-string "))"
-			     "(declare (ignorable true false "
-			     (getf subj-elem :variable-names) " "
-			     (getf pred-elem :variable-names) " "
-			     (getf obj-elem :variable-names) "))"
-			     "result)")))
-	  (when (eval (read-from-string expression))
-	    (push (list :subject (elt (subject-result construct) row-idx)
-			:predicate (elt (predicate-result construct) row-idx)
-			:object (elt (object-result construct) row-idx))
-		  results))))
-      (setf (subject-result construct)
-	    (map 'list #'(lambda(result) (getf result :subject)) results))
-      (setf (predicate-result construct)
-	    (map 'list #'(lambda(result) (getf result :predicate)) results))
-      (setf (object-result construct)
-	    (map 'list #'(lambda(result) (getf result :object)) results)))))
+(defgeneric make-variable-values(construct variable-name existing-results)
+  (:documentation "Returns a list of values that are bound to the passed
+                   variable. The first occurrence of the given variable
+                   is evaluated, since all occurrences have the same values,
+                   because reduce-results is called before and makes an
+                   intersection over all triples.")
+  (:method ((construct SPARQL-Query) (variable-name String) (existing-results List))
+    (let* ((found-p nil)
+	   (results
+	    (loop for triple in (select-group construct)
+	       when (and (variable-p (subject triple))
+			 (string= (value (subject triple)) variable-name))
+	       return (progn (setf found-p t)
+			     (subject-result triple))
+	       when (and (variable-p (predicate triple))
+			 (string= (value (predicate triple)) variable-name))
+	       return (progn (setf found-p t)
+			     (predicate-result triple))
+	       when (and (variable-p (object triple))
+			 (string= (value (object triple))
+				  variable-name))
+	       return (progn (setf found-p t)
+			     (object-result triple))))
+	   (new-results nil))
+      (if (not found-p)
+	  existing-results
+	  (if existing-results
+	      (dolist (result results new-results)
+		(dolist (old-result existing-results)
+		  (push (append old-result (list (list :variable-name variable-name
+						       :variable-value result)))
+			new-results)))
+	      (map 'list #'(lambda(result)
+			     (list (list :variable-name variable-name
+					 :variable-value result)))
+		   results))))))
+
+
+(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 "(let* ((true t)(false nil)"))
+    (dolist (var-elem variable-values)
+      (push-string (concat "(?" (getf var-elem :variable-name) " "
+			   (write-to-string (getf var-elem :variable-value)) ")")
+		   result)
+      (push-string (concat "($" (getf var-elem :variable-name) " "
+			   (write-to-string (getf var-elem :variable-value)) ")")
+		   result))
+    (push-string (concat "(result " filter "))") result)
+    (push-string "(declare (Ignorable true false " result)
+    (when variable-values
+      (dolist (var-elem variable-values)
+	(push-string (concat "?" (getf var-elem :variable-name) " ") result)
+	(push-string (concat "$" (getf var-elem :variable-name) " ") result)))
+    (push-string ")) result)" result)
+    (concat "(handler-case " result " (condition () nil))")))
+
+
+(defun return-false-values (all-values true-values)
+  "Returns a list that contains all values from all-values that
+   are not contained in true-values."
+  (let ((local-all-values
+	 (remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values)
+			    :test #'variable-list=))
+	(results nil))
+    (dolist (value local-all-values)
+      (when (not (find value true-values :test #'variable-list=))
+	(push value results)))
+    results))
+
+
+(defun variable-list= (x y)
+  (and (string= (getf x :variable-name)
+		(getf y :variable-name))
+       (literal= (getf x :variable-value)
+		 (getf y :variable-value))))
+
+
+(defgeneric process-filters (construct)
+  (:documentation "Processes all filters by calling invoke-filter.")
+  (:method ((construct SPARQL-Query))
+    (dolist (filter (filters construct))
+      (let* ((filter-variable-names
+	      (get-variables-from-filter-string filter))
+	     (filter-variable-values nil)
+	     (true-values nil))
+	(dolist (var-name filter-variable-names)
+	  (setf filter-variable-values
+		(make-variable-values construct var-name filter-variable-values)))
+	(dolist (filter (filters construct))
+	  (dolist (var-elem filter-variable-values)
+	    (when (eval (read-from-string (to-lisp-code var-elem filter)))
+	      (map 'list #'(lambda(list-elem)
+			     (push list-elem true-values))
+		   var-elem))))
+	(let ((values-to-remove
+	       (return-false-values filter-variable-values
+				    (remove-duplicates true-values
+						       :test #'variable-list=))))
+	  (dolist (to-del values-to-remove)
+	    (delete-rows-by-value construct (getf to-del :variable-name)
+				  (getf to-del :variable-value))))))
+    construct))
+
+
+(defgeneric idx-of (construct variable-name variable-value &key what)
+  (:documentation "Returns the idx of the variable with the name
+                   variable-name and the value variable-value.")
+  (:method ((construct SPARQL-Triple) (variable-name String)
+	    variable-value &key (what :subject))
+    (declare (Keyword what))
+    (let ((result nil)
+	  (local-results
+	   (cond ((eql what :subject) (subject-result construct))
+		 ((eql what :predicate) (predicate-result construct))
+		 ((eql what :object) (object-result construct))))
+	  (is-variable
+	   (cond ((eql what :subject)
+		  (and (variable-p (subject construct))
+		       (value (subject construct))))
+		 ((eql what :predicate)
+		  (and (variable-p (predicate construct))
+		       (value (predicate construct))))
+		 ((eql what :object)
+		  (and (variable-p (object construct))
+		       (value (object construct)))))))
+      (when is-variable
+	(remove-null
+	 (dotimes (idx (length local-results))
+	   (when (literal= variable-value (elt local-results idx))
+	     (push idx result)))))
+      result)))
+
+
+(defgeneric delete-rows-by-value (construct variable-name value-to-delete)
+  (:documentation "Deletes all rows that owns a variable with the
+                   given value.")
+  (:method ((construct SPARQL-Query) (variable-name String) value-to-delete)
+    (dolist (triple (select-group construct))
+      (let* ((subj-delete-idx-lst
+	      (idx-of triple variable-name value-to-delete))
+	     (pred-delete-idx-lst
+	      (idx-of triple variable-name value-to-delete :what :predicate))
+	     (obj-delete-idx-lst
+	      (idx-of triple variable-name value-to-delete :what :object))
+	     (all-idxs (union (union subj-delete-idx-lst
+				     pred-delete-idx-lst)
+			      obj-delete-idx-lst)))
+	(when all-idxs
+	  (let ((new-values nil))
+	    (dotimes (idx (length (subject-result triple)))
+	      (when (not (find idx all-idxs))
+		(push
+		 (list :subject (elt (subject-result triple) idx)
+		       :predicate (elt (predicate-result triple) idx)
+		       :object (elt (object-result triple) idx))
+		 new-values)))
+	    (setf (subject-result triple)
+		  (map 'list #'(lambda(elem) (getf elem :subject)) new-values))
+	    (setf (predicate-result triple)
+		  (map 'list #'(lambda(elem) (getf elem :predicate)) new-values))
+	    (setf (object-result triple)
+		  (map 'list #'(lambda(elem) (getf elem :object)) new-values))))))
+    construct))
 
 
 (defgeneric set-results (construct &key revision)
@@ -333,7 +443,7 @@
   "Returns '<'uri-string'>' if uri-string is not a string uri-string
    is returned as result."
   (if (typep uri-string 'String)
-      (concatenate 'string "<" uri-string ">")
+      (concat "<" uri-string ">")
       uri-string))
 
 
@@ -884,7 +994,7 @@
 
 
 (defmethod all-variables ((construct SPARQL-Query))
-  "Returns all variables that are contained in the select groupt memebers."
+  "Returns all variables that are contained in the select group memebers."
   (remove-duplicates
    (remove-null
     (loop for triple in (select-group construct)
@@ -1054,7 +1164,8 @@
   ;; filters all entries that are not important for the result
   ;; => an intersection is invoked
   (reduce-results construct (make-result-lists construct))
-  (dolist (triple (select-group construct))
-    (dolist (filter (filters construct))
-      (invoke-filter triple filter)))
+;  (dolist (triple (select-group construct))
+;    (dolist (filter (filters construct))
+;      (invoke-filter triple construct filter)))
+  (process-filters construct)
   construct)
\ No newline at end of file

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Tue Dec 21 17:57:57 2010
@@ -571,6 +571,7 @@
 	    (when inner-value 
 	      (+ inner-value (1+ (length (name-after-paranthesis
 					  (subseq left-string inner-value))))))))
+	 
 	 (start-idx (if first-bracket
 			first-bracket
 			0)))
@@ -949,4 +950,28 @@
 	      t))
 	(if (find string-before *supported-functions* :test #'string=)
 	    nil
-	    t))))
\ No newline at end of file
+	    t))))
+
+
+(defun get-variables-from-filter-string(filter-string)
+  "Returns a list of string with all variables that are used in this filter."
+  (let ((variables nil))
+    (dotimes (idx (length filter-string))
+      (let ((current-string (subseq filter-string idx)))
+	(when (and (or (string-starts-with current-string "?")
+		       (string-starts-with current-string "$"))
+		   (not (in-literal-string-p filter-string idx)))
+	  (let ((end-pos
+		 (let ((inner-value
+			(search-first
+			 (append (list " " "?" "$" "." ",")
+				 (*supported-operators*)
+				 *supported-brackets*
+				 (map 'list #'string (white-space)))
+			 (subseq current-string 1))))
+		   (if inner-value
+		       (1+ inner-value)
+		       (length current-string)))))
+	    (push (subseq current-string 1 end-pos) variables)
+	    (incf idx end-pos)))))
+    (remove-duplicates variables :test #'string=)))
\ No newline at end of file

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Dec 21 17:57:57 2010
@@ -38,7 +38,8 @@
 	   :test-set-+-and---operators
 	   :test-set-compare-operators
 	   :test-set-functions
-	   :test-module-1))
+	   :test-module-1
+	   :test-module-2))
 
 
 (in-package :sparql-test)
@@ -1599,6 +1600,32 @@
 			 (list "Johann Wolfgang" "von Goethe"
 			       "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")
 			 :test #'string=))))))))
+
+
+(test test-module-2
+  "Tests the entire module."
+  (with-fixture with-tm-filled-db ("data_base" *poems.xtm*)
+    (with-revision 0
+      (let* ((query-1
+	      "PREFIX poem:<http://some.where/psis/poem/>
+               PREFIX author:<http://some.where/psis/author/>
+               PREFIX main:<http://some.where/base-psis/>
+               PREFIX tmdm:<http://psi.topicmaps.org/iso13250/model/>
+               SELECT ?poems WHERE{
+                ?poems tmdm:type main:poem . #self as ?x a <y>
+	        ?poems main:title ?titles .
+  	        FILTER (REGEX(?titles, '[a-zA-Z]+ [a-zA-Z]+')) }")
+	     (result-1
+	      (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))))
+	(is-true result-1)
+	(is (= (length result-1) 1))
+	(is (string= (getf (first result-1) :variable) "poems"))
+	(is-false (set-exclusive-or
+		   (getf (first result-1) :result)
+		   (list "<http://some.where/psis/poem/resignation>"
+			 "<http://some.where/psis/poem/erlkoenig>"
+			 "<http://some.where/psis/poem/zauberlehrling>")
+		   :test #'string=))))))
     
 
 (defun run-sparql-tests ()