[isidorus-cvs] r397 - in trunk/src: . TM-SPARQL base-tools unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Mar 31 11:34:18 UTC 2011
Author: lgiessmann
Date: Thu Mar 31 07:34:18 2011
New Revision: 397
Log:
tm-sparql: finished all unittests that checks the api's behaviour with different literal datatypes => fixed several bugs that handles xml-boolean, xml-integer, xml-decimal, xml-double, and xml-date values; fixed a bug in the xtm test file; extended the function "literal=" so any objects can be compared to other objects in the string^^datatype format.
Modified:
trunk/src/TM-SPARQL/sparql.lisp
trunk/src/TM-SPARQL/sparql_parser.lisp
trunk/src/TM-SPARQL/tmsparql_core_psis.xtm
trunk/src/base-tools/base-tools.lisp
trunk/src/constants.lisp
trunk/src/isidorus.asd
trunk/src/unit_tests/sparql_test.lisp
trunk/src/unit_tests/sparql_test.xtm
trunk/src/unit_tests/unittests-constants.lisp
Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp (original)
+++ trunk/src/TM-SPARQL/sparql.lisp Thu Mar 31 07:34:18 2011
@@ -502,7 +502,8 @@
(defun return-characteristics (literal-value literal-datatype)
- "Returns all characteristica that own the specified value."
+ "Returns all characteristica that own the specified value.
+ Note the type xsd:date is not supported and so handled as a string."
(declare (String literal-datatype))
(let ((chars
(cond ((string= literal-datatype *xml-string*)
@@ -516,7 +517,8 @@
(elephant:get-instances-by-value
'NameC 'charvalue literal-value))))
((and (string= literal-datatype *xml-boolean*)
- literal-value)
+ (or (and (stringp literal-value) (string= literal-value "true"))
+ (and (typep literal-value 'Boolean) literal-value)))
(remove-if #'(lambda(elem)
(string/= (charvalue elem) "true"))
(append (elephant:get-instances-by-value
@@ -524,7 +526,8 @@
(elephant:get-instances-by-value
'OccurrenceC 'charvalue "true"))))
((and (string= literal-datatype *xml-boolean*)
- (not literal-value))
+ (or (and (stringp literal-value) (string= literal-value "false"))
+ (and (typep literal-value 'Boolean) (not literal-value))))
(remove-if #'(lambda(elem)
(string/= (charvalue elem) "false"))
(append (elephant:get-instances-by-value
@@ -541,9 +544,15 @@
(elephant:get-instances-by-value
'VariantC 'datatype literal-datatype)
(elephant:get-instances-by-value
- 'OccurrenceC 'datatype literal-datatype)))))
+ 'OccurrenceC 'datatype literal-datatype))))
+ (user-val (if (stringp literal-value)
+ (concat "\"\"\"" literal-value "\"\"\"^^"
+ literal-datatype)
+ literal-value)))
(remove-if #'(lambda(con)
- (not (literal= (charvalue con) literal-value)))
+ (not (literal= (concat "\"\"\"" (charvalue con)
+ "\"\"\"^^" (datatype con))
+ user-val)))
constructs))))))
;;elephant returns names, occurences, and variants if any string
;;value matches, so all duplicates have to be removed
@@ -830,24 +839,53 @@
(get-item-by-any-id (value construct) :revision revision)))))
+(defun split-literal-string (literal-string)
+ "Returns a list of the form (:value literal-value :datatype literal-type)
+ of a string literal-value^^literal-type."
+ (when (stringp literal-string)
+ (let ((str (cut-comment literal-string)))
+ (when (string-starts-with-one-of literal-string (list "\"" "'"))
+ (let* ((delimiter (cond ((string-starts-with str "'") "'")
+ ((string-starts-with str "\"\"\"") "\"\"\"")
+ (t "\"")))
+ (l-end (find-literal-end (subseq str (length delimiter)) delimiter))
+ (l-value (subseq str (length delimiter) l-end))
+ (l-rest (subseq str (+ (length delimiter) l-end)))
+ (l-type (if (string-starts-with l-rest "^^")
+ (subseq l-rest 2)
+ *xml-string*)))
+ (list :value l-value :datatype l-type))))))
+
+
(defun literal= (value-1 value-2)
"Returns t if both arguments are equal. The equality function is searched in
the table *equal-operators*."
- (when (or (and (numberp value-1) (numberp value-2))
- (typep value-1 (type-of value-2))
- (typep value-2 (type-of value-1)))
- (let ((operator (get-equal-operator value-1)))
- (funcall operator value-1 value-2))))
+ (let ((real-value-1 (let ((result (split-literal-string value-1)))
+ (if result
+ (cast-literal (getf result :value)
+ (getf result :datatype))
+ value-1)))
+ (real-value-2 (let ((result (split-literal-string value-2)))
+ (if result
+ (cast-literal (getf result :value)
+ (getf result :datatype))
+ value-2))))
+ (when (or (and (numberp real-value-1) (numberp real-value-2))
+ (typep value-1 (type-of real-value-2))
+ (typep value-2 (type-of real-value-1)))
+ (let ((operator (get-equal-operator real-value-1)))
+ (funcall operator real-value-1 real-value-2)))))
(defun filter-datatypable-by-value (construct literal-value literal-datatype)
"A helper that compares the datatypable's charvalue with the passed
literal value."
(declare (d::DatatypableC construct)
- (type (or Null String) literal-value literal-datatype))
+ (type (or Null String) literal-datatype))
(when (or (not literal-datatype)
(string= (datatype construct) literal-datatype))
- (if (not literal-value)
+ (if (and (not literal-value)
+ (string/= literal-datatype *xml-boolean*))
construct
(handler-case
(let ((occ-value (cast-literal (charvalue construct)
@@ -869,7 +907,7 @@
"A helper that compares the occurrence's charvalue with the passed
literal value."
(declare (OccurrenceC occurrence)
- (type (or Null String) literal-value literal-datatype))
+ (type (or Null String) literal-datatype))
(filter-datatypable-by-value occurrence literal-value literal-datatype))
@@ -919,7 +957,8 @@
(by-literal (if literal-value
(names-by-value
construct #'(lambda(name)
- (string= name literal-value))
+ (literal= name literal-value))
+ ;(string= name literal-value))
:revision revision)
(names construct :revision revision)))
(all-names (intersection by-type by-literal))
Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp (original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp Thu Mar 31 07:34:18 2011
@@ -288,17 +288,21 @@
(triple-delimiters
(list ". " ";" " " (string #\tab)
(string #\newline) "}"))
- (end-pos (search-first triple-delimiters
- trimmed-str)))
+ (end-pos (search-first triple-delimiters trimmed-str)))
(unless end-pos
(error (make-sparql-parser-condition
trimmed-str (original-query construct)
"'. ', , ';' ' ', '\\t', '\\n' or '}'")))
(let* ((literal-number
- (read-from-string (subseq trimmed-str 0 end-pos)))
+ (read-from-string
+ (let ((str-value (subseq trimmed-str 0 end-pos)))
+ (if (string-ends-with str-value ".")
+ (progn (decf end-pos)
+ (subseq str-value 0 (1- (length str-value))))
+ str-value))))
(number-type
(if (search "." (subseq trimmed-str 0 end-pos))
- *xml-double* ;could also be an xml:decimal, since the doucble has
+ *xml-double* ;could also be an xml:decimal, since the double has
;a bigger range it shouldn't matter
*xml-integer*)))
(unless (numberp literal-number)
Modified: trunk/src/TM-SPARQL/tmsparql_core_psis.xtm
==============================================================================
--- trunk/src/TM-SPARQL/tmsparql_core_psis.xtm (original)
+++ trunk/src/TM-SPARQL/tmsparql_core_psis.xtm Thu Mar 31 07:34:18 2011
@@ -42,4 +42,7 @@
<subjectIdentifier href="http://www.networkedplanet.com/tmsparql/value"/>
</topic>
+ <topic id="rdf-type">
+ <subjectIdentifier href="http://www.w3.org/1999/02/22-rdf-syntax-ns#type"/>
+ </topic>
</topicMap>
Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp (original)
+++ trunk/src/base-tools/base-tools.lisp Thu Mar 31 07:34:18 2011
@@ -113,20 +113,23 @@
(defun trim-whitespace-left (value)
"Uses string-left-trim with a predefined character-list."
- (declare (String value))
- (string-left-trim *white-space* value))
+ (declare (type (or Null String) value))
+ (when 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 *white-space* value))
+ (declare (type (or Null String) value))
+ (when value
+ (string-right-trim *white-space* value)))
(defun trim-whitespace (value)
"Uses string-trim with a predefined character-list."
- (declare (String value))
- (string-trim *white-space* value))
+ (declare (type (or Null String) value))
+ (when value
+ (string-trim *white-space* value)))
(defun string-starts-with (str prefix &key (ignore-case nil))
Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp (original)
+++ trunk/src/constants.lisp Thu Mar 31 07:34:18 2011
@@ -30,6 +30,7 @@
:*xml-decimal*
:*xml-double*
:*xml-integer*
+ :*xml-date*
:*xml-uri*
:*rdf2tm-ns*
:*rdf-statement*
@@ -109,6 +110,8 @@
(defparameter *xml-integer* "http://www.w3.org/2001/XMLSchema#integer")
+(defparameter *xml-date* "http://www.w3.org/2001/XMLSchema#date")
+
(defparameter *xml-decimal* "http://www.w3.org/2001/XMLSchema#decimal")
(defparameter *xml-double* "http://www.w3.org/2001/XMLSchema#double")
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Thu Mar 31 07:34:18 2011
@@ -149,6 +149,7 @@
(:static-file "reification_xtm1.0.xtm")
(:static-file "reification_xtm2.0.xtm")
(:static-file "reification.rdf")
+ (:static-file "sparql_test.xtm")
(:file "atom-conf")
(:file "unittests-constants"
:depends-on ("dangling_topicref.xtm"
Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp (original)
+++ trunk/src/unit_tests/sparql_test.lisp Thu Mar 31 07:34:18 2011
@@ -1625,7 +1625,63 @@
"<http://some.where/psis/poem/erlkoenig>"
"<http://some.where/psis/poem/zauberlehrling>")
:test #'string=))))))
-
+
+
+(test test-all-1
+ "Tests the entire module with the file sparql_test.xtm"
+ (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+ (tm-sparql:init-tm-sparql)
+ (let* ((q-1 (concat
+ "SELECT * WHERE {
+ ?subj1 <http://some.where/tmsparql/first-name> \"Johann Wolfgang\".
+ ?subj2 <http://some.where/tmsparql/last-name> 'von Goethe'^^"
+ *xml-string* ".
+ ?subj3 <http://some.where/tmsparql/date-of-birth> '28.08.1749'^^"
+ *xml-date* ".
+ ?subj4 <http://some.where/tmsparql/date-of-death> '22.03.1832'^^"
+ *xml-date* ".
+ ?subj5 <http://some.where/tmsparql/years> 82.0.
+ ?subj6 <http://some.where/tmsparql/years> 82.
+ ?subj7 <http://some.where/tmsparql/years> '82'^^" *xml-integer* ".
+ ?subj8 <http://some.where/tmsparql/isDead> true.
+ ?subj9 <http://some.where/tmsparql/isDead> 'true'^^" *xml-boolean* ".
+ ?subj10 <http://some.where/tmsparql/isDead> 'false'^^" *xml-boolean* ".
+ ?subj11 <http://some.where/tmsparql/isDead> false"
+ "}"))
+ (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+ (is-true (= (length r-1) 11))
+ (map 'list #'(lambda(item)
+ (cond ((or (string= (getf item :variable) "subj1")
+ (string= (getf item :variable) "subj2")
+ (string= (getf item :variable) "subj3")
+ (string= (getf item :variable) "subj4")
+ (string= (getf item :variable) "subj6")
+ (string= (getf item :variable) "subj7")
+ (string= (getf item :variable) "subj8")
+ (string= (getf item :variable) "subj9"))
+ (is (string= (first (getf item :result))
+ "<http://some.where/tmsparql/author/goethe>")))
+ ((or (string= (getf item :variable) "subj5")
+ (string= (getf item :variable) "subj10")
+ (string= (getf item :variable) "subj11"))
+ (is-false (getf item :result)))
+ (t
+ (is-true (format t "bad variable-name found")))))
+ r-1))
+ (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/topicProperty"
+ :revision 0))
+ (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/reifier"
+ :revision 0))
+ (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/role"
+ :revision 0))
+ (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/player"
+ :revision 0))
+ (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/scope"
+ :revision 0))
+ (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/value"
+ :revision 0))
+ (is-true (d:get-item-by-psi *rdf-type* :revision 0))))
+
(defun run-sparql-tests ()
(it.bese.fiveam:run! 'sparql-test:sparql-tests))
Modified: trunk/src/unit_tests/sparql_test.xtm
==============================================================================
--- trunk/src/unit_tests/sparql_test.xtm (original)
+++ trunk/src/unit_tests/sparql_test.xtm Thu Mar 31 07:34:18 2011
@@ -73,7 +73,7 @@
</tm:topic>
<tm:topic id="last-name">
- <tm:subjectIdentifier href="http://some.where/tmsparql/first-name"/>
+ <tm:subjectIdentifier href="http://some.where/tmsparql/last-name"/>
<tm:instanceOf><tm:topicRef href="#nametype"/></tm:instanceOf>
</tm:topic>
@@ -117,6 +117,11 @@
<tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
</tm:topic>
+ <tm:topic id="isAlive">
+ <tm:subjectIdentifier href="http://some.where/tmsparql/isAlive"/>
+ <tm:instanceOf><tm:topicRef href="#occurrencetype"/></tm:instanceOf>
+ </tm:topic>
+
<tm:topic id="reifier-type">
<tm:subjectIdentifier href="http://some.where/tmsparql/reifier-type"/>
<tm:instanceOf><tm:topicRef href="#topictype"/></tm:instanceOf>
@@ -147,19 +152,23 @@
<tm:occurrence reifier="http://some.where/ii/goethe-occ-reifier">
<tm:itemIdentity href="http://some.where/ii/goethe-occ"/>
<tm:type><tm:topicRef href="#date-of-birth"/></tm:type>
- <tm:resourceData href="http://www.w3.org/2001/XMLSchema#date">28.08.1749</tm:resourceData>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#date">28.08.1749</tm:resourceData>
</tm:occurrence>
<tm:occurrence>
<tm:type><tm:topicRef href="#date-of-death"/></tm:type>
- <tm:resourceData href="http://www.w3.org/2001/XMLSchema#integer">22.03.1832</tm:resourceData> <!-- bad data type -->
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#date">22.03.1832</tm:resourceData>
</tm:occurrence>
<tm:occurrence>
<tm:type><tm:topicRef href="#years"/></tm:type>
- <tm:resourceData href="http://www.w3.org/2001/XMLSchema#integer">82</tm:resourceData>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#integer">82</tm:resourceData>
</tm:occurrence>
<tm:occurrence>
<tm:type><tm:topicRef href="#isDead"/></tm:type>
- <tm:resourceData href="http://www.w3.org/2001/XMLSchema#boolean">true</tm:resourceData>
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#boolean">true</tm:resourceData>
+ </tm:occurrence>
+ <tm:occurrence>
+ <tm:type><tm:topicRef href="#isAlive"/></tm:type> <!-- redundancy: needed for checking booleans -->
+ <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#boolean">false</tm:resourceData>
</tm:occurrence>
</tm:topic>
Modified: trunk/src/unit_tests/unittests-constants.lisp
==============================================================================
--- trunk/src/unit_tests/unittests-constants.lisp (original)
+++ trunk/src/unit_tests/unittests-constants.lisp Thu Mar 31 07:34:18 2011
@@ -30,6 +30,7 @@
:*atom_test.xtm*
:*atom-conf.lisp*
:*poems.xtm*
+ :*sparql_test.xtm*
:*poems_light.rdf*
:*poems_light.xtm*
:*poems_light.xtm.txt*
@@ -105,6 +106,10 @@
(asdf:component-pathname
(asdf:find-component *unit-tests-component* "poems.xtm")))
+(defparameter *sparql_test.xtm*
+ (asdf:component-pathname
+ (asdf:find-component *unit-tests-component* "sparql_test.xtm")))
+
(defparameter *poems_light.rdf*
(asdf:component-pathname
(asdf:find-component *unit-tests-component* "poems_light.rdf")))
More information about the Isidorus-cvs
mailing list