- isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

[isidorus-cvs] r384 - in trunk/src: . TM-SPARQL base-tools json model rest_interface unit_tests xml/rdf xml/xtm
by Lukas Giessmann 05 Jan '11

05 Jan '11

Author: lgiessmann Date: Wed Jan 5 18:37:15 2011 New Revision: 384 Log: code-maintenance: replaced some code sections by functions of base-tools; removed some "hacks" in the code 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/constants.lisp trunk/src/isidorus.asd trunk/src/json/json_exporter.lisp trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_validation.lisp trunk/src/model/datamodel.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/datamodel_test.lisp trunk/src/unit_tests/json_test.lisp trunk/src/unit_tests/rdf_exporter_test.lisp trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/unit_tests/sparql_test.lisp trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/exporter_xtm1.0.lisp trunk/src/xml/xtm/exporter_xtm2.0.lisp trunk/src/xml/xtm/importer.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp trunk/src/xml/xtm/tools.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Jan 5 18:37:15 2011 @@ -203,9 +203,9 @@ (defgeneric (setf elem-type) (construct elem-type) (:documentation "Sets the passed elem-type on the passed cosntruct.") (:method ((construct SPARQL-Triple-Elem) (elem-type Symbol)) - (unless (and (eql elem-type 'IRI) - (eql elem-type 'VARIABLE) - (eql elem-type 'LITERAL)) + (when (and (not (eql elem-type 'IRI)) + (not (eql elem-type 'VARIABLE)) + (not (eql elem-type 'LITERAL))) (error (make-condition 'bad-argument-error :message (format nil "Expected a one of the symbols ~a, but get ~a~%" @@ -470,7 +470,7 @@ or name. The subject is the owner topic and the predicate is the characteristic's type." (declare (Integer revision) - (String literal-value literal-datatype)) + (String literal-datatype)) (let ((chars (cond ((string= literal-datatype *xml-string*) (remove-if #'(lambda(elem) @@ -481,13 +481,13 @@ (elephant:get-instances-by-value 'NameC 'charvalue literal-value)))) ((and (string= literal-datatype *xml-boolean*) - (eql literal-value t)) + literal-value) (remove-if #'(lambda(elem) (string/= (charvalue elem) "true")) (elephant:get-instances-by-value 'OccurrenceC 'charvalue "true"))) ((and (string= literal-datatype *xml-boolean*) - (eql literal-value nil)) + (not literal-value)) (remove-if #'(lambda(elem) (string/= (charvalue elem) "false")) (elephant:get-instances-by-value Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Wed Jan 5 18:37:15 2011 @@ -181,8 +181,8 @@ (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 ")" + (concat + left-str "(" fun-name " " cleaned-arg-list ")" (subseq right-str (+ (- (length right-str) (length cleaned-right-str)) (length arg-list)))))) @@ -240,11 +240,10 @@ (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))))) + (concat (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)))))) @@ -357,9 +356,9 @@ (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))) + (concat + (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)))))) @@ -438,11 +437,10 @@ (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))))) + (concat (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)))))) @@ -537,11 +535,11 @@ (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))))) + (concat (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))))) (when (or (= (length (trim-whitespace left-scope)) 0) (= (length (trim-whitespace right-scope)) 0)) (error (make-condition @@ -666,7 +664,7 @@ (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 " ") + (push-string (concat "(one" current-char " ") result-string) (push-string (set-unary-operators construct (getf result :scope)) @@ -754,7 +752,7 @@ (when fun-suffix (let* ((args (bracket-scope fun-suffix)) (fun-name (string-until cleaned-str args))) - (concatenate 'string fun-name args))))) + (concat fun-name args))))) (defun get-filter-variable (str) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Wed Jan 5 18:37:15 2011 @@ -228,8 +228,8 @@ (string #\newline))) (delimiters-2 (list " ." ". " ";" "}" " " (string #\tab) (string #\newline) - (concatenate 'string "." (string #\newline)) - (concatenate 'string "." (string #\tab))))) + (concat "." (string #\newline)) + (concat "." (string #\tab))))) (cond ((string-starts-with query-string "@") (let ((end-pos (search-first delimiters-1 (subseq query-string 1)))) @@ -344,7 +344,7 @@ (string-after elem-str ":"))) (full-url (when (and suffix prefix) - (get-prefix construct (concatenate 'string prefix ":" suffix))))) + (get-prefix construct (concat prefix ":" suffix))))) (unless (and end-pos prefix suffix) (error (make-sparql-parser-condition trimmed-str (original-query construct) @@ -355,9 +355,8 @@ :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))) + (string-after trimmed-str + (concat prefix ":" suffix))) :value (make-instance 'SPARQL-Triple-Elem :elem-type 'IRI :value full-url))))) Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Wed Jan 5 18:37:15 2011 @@ -59,14 +59,14 @@ *white-space*)) +(defmacro concat (&rest strings) + `(concatenate 'string ,@strings)) + + (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." - `(setf ,place (concatenate 'string ,place ,obj))) - - -(defmacro concat (&rest strings) - `(concatenate 'string ,@strings)) + `(setf ,place (concat ,place ,obj))) (defmacro when-do (result-bounding condition-statement do-with-result) @@ -103,12 +103,12 @@ (remove-if #'null (map 'list #'(lambda(item) (when (stringp item) - (concatenate 'string "/" item))) + (concat "/" item))) (pathname-directory pathname)))) (full-path-string "")) (dolist (segment segments) (push-string segment full-path-string)) - (concatenate 'string full-path-string "/" (pathname-name pathname)))) + (concat full-path-string "/" (pathname-name pathname)))) (defun trim-whitespace-left (value) @@ -193,9 +193,10 @@ (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)))))) + (concat (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)))))) @@ -225,7 +226,7 @@ (type (or Null String) digits)) (if (string-starts-with-digit str) (separate-leading-digits - (subseq str 1) (concatenate 'string digits (subseq str 0 1))) + (subseq str 1) (concat digits (subseq str 0 1))) digits)) @@ -314,9 +315,9 @@ (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))))) + :literal (concat quotation + (subseq query-string 3 literal-end) + quotation))))) ((or (string-starts-with query-string "\"") (string-starts-with query-string "'")) (unless local-quotation @@ -328,8 +329,8 @@ (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))))))))) + :literal (concat local-quotation literal + local-quotation))))))))) (defun search-first-ignore-literals (search-strings main-string &key from-end) @@ -396,7 +397,7 @@ (setf separator "/")) (subseq absolute-ns 0 (- (length absolute-ns) 1))) absolute-ns)))) - (concatenate 'string prep-ns separator value))))) + (concat prep-ns separator value))))) (defun absolute-uri-p (uri) Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Wed Jan 5 18:37:15 2011 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :constants - (:use :cl) + (:use :cl :base-tools) (:export :*atom-ns* :*egovpt-ns* :*instance-psi* @@ -117,74 +117,74 @@ (defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/") -(defparameter *rdf-statement* (concatenate 'string *rdf-ns* "Statement")) +(defparameter *rdf-statement* (concat *rdf-ns* "Statement")) -(defparameter *rdf-object* (concatenate 'string *rdf-ns* "object")) +(defparameter *rdf-object* (concat *rdf-ns* "object")) -(defparameter *rdf-subject* (concatenate 'string *rdf-ns* "subject")) +(defparameter *rdf-subject* (concat *rdf-ns* "subject")) -(defparameter *rdf-predicate* (concatenate 'string *rdf-ns* "predicate")) +(defparameter *rdf-predicate* (concat *rdf-ns* "predicate")) -(defparameter *rdf-nil* (concatenate 'string *rdf-ns* "nil")) +(defparameter *rdf-nil* (concat *rdf-ns* "nil")) -(defparameter *rdf-type* (concatenate 'string *rdf-ns* "type")) +(defparameter *rdf-type* (concat *rdf-ns* "type")) -(defparameter *rdf-first* (concatenate 'string *rdf-ns* "first")) +(defparameter *rdf-first* (concat *rdf-ns* "first")) -(defparameter *rdf-rest* (concatenate 'string *rdf-ns* "rest")) +(defparameter *rdf-rest* (concat *rdf-ns* "rest")) -(defparameter *rdf2tm-object* (concatenate 'string *rdf2tm-ns* "object")) +(defparameter *rdf2tm-object* (concat *rdf2tm-ns* "object")) -(defparameter *rdf2tm-subject* (concatenate 'string *rdf2tm-ns* "subject")) +(defparameter *rdf2tm-subject* (concat *rdf2tm-ns* "subject")) -(defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/")) +(defparameter *rdf2tm-scope-prefix* (concat *rdf2tm-ns* "scope/")) -(defparameter *rdf2tm-blank-node-prefix* (concatenate 'string *rdf2tm-ns* "blank_node/")) +(defparameter *rdf2tm-blank-node-prefix* (concat *rdf2tm-ns* "blank_node/")) (defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/") -(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "types/Topic")) +(defparameter *tm2rdf-topic-type-uri* (concat *tm2rdf-ns* "types/Topic")) -(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "types/Name")) +(defparameter *tm2rdf-name-type-uri* (concat *tm2rdf-ns* "types/Name")) -(defparameter *tm2rdf-name-property* (concatenate 'string *tm2rdf-ns* "name")) +(defparameter *tm2rdf-name-property* (concat *tm2rdf-ns* "name")) -(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "types/Variant")) +(defparameter *tm2rdf-variant-type-uri* (concat *tm2rdf-ns* "types/Variant")) -(defparameter *tm2rdf-variant-property* (concatenate 'string *tm2rdf-ns* "variant")) +(defparameter *tm2rdf-variant-property* (concat *tm2rdf-ns* "variant")) -(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "types/Occurrence")) +(defparameter *tm2rdf-occurrence-type-uri* (concat *tm2rdf-ns* "types/Occurrence")) -(defparameter *tm2rdf-occurrence-property* (concatenate 'string *tm2rdf-ns* "occurrence")) +(defparameter *tm2rdf-occurrence-property* (concat *tm2rdf-ns* "occurrence")) -(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "types/Role")) +(defparameter *tm2rdf-role-type-uri* (concat *tm2rdf-ns* "types/Role")) -(defparameter *tm2rdf-role-property* (concatenate 'string *tm2rdf-ns* "role")) +(defparameter *tm2rdf-role-property* (concat *tm2rdf-ns* "role")) -(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "types/Association")) +(defparameter *tm2rdf-association-type-uri* (concat *tm2rdf-ns* "types/Association")) -(defparameter *tm2rdf-association-property* (concatenate 'string *tm2rdf-ns* "association")) +(defparameter *tm2rdf-association-property* (concat *tm2rdf-ns* "association")) -(defparameter *tm2rdf-subjectIdentifier-property* (concatenate 'string *tm2rdf-ns* "subjectIdentifier")) +(defparameter *tm2rdf-subjectIdentifier-property* (concat *tm2rdf-ns* "subjectIdentifier")) -(defparameter *tm2rdf-subjectLocator-property* (concatenate 'string *tm2rdf-ns* "subjectLocator")) +(defparameter *tm2rdf-subjectLocator-property* (concat *tm2rdf-ns* "subjectLocator")) -(defparameter *tm2rdf-itemIdentity-property* (concatenate 'string *tm2rdf-ns* "itemIdentity")) +(defparameter *tm2rdf-itemIdentity-property* (concat *tm2rdf-ns* "itemIdentity")) -(defparameter *tm2rdf-value-property* (concatenate 'string *tm2rdf-ns* "value")) +(defparameter *tm2rdf-value-property* (concat *tm2rdf-ns* "value")) -(defparameter *tm2rdf-nametype-property* (concatenate 'string *tm2rdf-ns* "nametype")) +(defparameter *tm2rdf-nametype-property* (concat *tm2rdf-ns* "nametype")) -(defparameter *tm2rdf-scope-property* (concatenate 'string *tm2rdf-ns* "scope")) +(defparameter *tm2rdf-scope-property* (concat *tm2rdf-ns* "scope")) -(defparameter *tm2rdf-varianttype-property* (concatenate 'string *tm2rdf-ns* "varianttype")) +(defparameter *tm2rdf-varianttype-property* (concat *tm2rdf-ns* "varianttype")) -(defparameter *tm2rdf-occurrencetype-property* (concatenate 'string *tm2rdf-ns* "occurrencetype")) +(defparameter *tm2rdf-occurrencetype-property* (concat *tm2rdf-ns* "occurrencetype")) -(defparameter *tm2rdf-roletype-property* (concatenate 'string *tm2rdf-ns* "roletype")) +(defparameter *tm2rdf-roletype-property* (concat *tm2rdf-ns* "roletype")) -(defparameter *tm2rdf-associationtype-property* (concatenate 'string *tm2rdf-ns* "associationtype")) +(defparameter *tm2rdf-associationtype-property* (concat *tm2rdf-ns* "associationtype")) -(defparameter *tm2rdf-player-property* (concatenate 'string *tm2rdf-ns* "player")) +(defparameter *tm2rdf-player-property* (concat *tm2rdf-ns* "player")) -(defparameter *tm2rdf-reifier-property* (concatenate 'string *tm2rdf-ns* "reifier")) +(defparameter *tm2rdf-reifier-property* (concat *tm2rdf-ns* "reifier")) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Jan 5 18:37:15 2011 @@ -19,8 +19,8 @@ :version "0.1" :author "Marc Kuester, Christoph Ludwig, Lukas Georgieff" :licence "LGPL" - :components ( - (:file "constants") + :components ((:file "constants" + :depends-on ("base-tools")) (:static-file "xml/xtm/core_psis.xtm") (:static-file "xml/rdf/rdf_core_psis.xtm") (:file "xml-constants" @@ -76,6 +76,7 @@ :depends-on ("xtm"))) :depends-on ("constants" "xml-constants" + "base-tools" "model" "threading" "base-tools")) @@ -109,7 +110,8 @@ "xml" "TM-SPARQL" "json" - "threading")) + "threading" + "base-tools")) (:module "unit_tests" :components ((:static-file "textgrid.xtm") (:static-file "textgrid_old.xtm") @@ -197,7 +199,8 @@ :depends-on ("json_tmcl_validation" "json_importer")) (:file "json_delete_interface" :depends-on ("json_importer"))) - :depends-on ("model" + :depends-on ("base-tools" + "model" "xml" "TM-SPARQL")) (:module "ajax" Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Wed Jan 5 18:37:15 2011 @@ -43,24 +43,23 @@ (defun resourceX-to-json-string (value datatype &key (xtm-id d:*current-xtm*)) "returns a resourceRef and resourceData json object" - ;(declare (string value datatype)) (if (string= datatype "http://www.w3.org/2001/XMLSchema#anyURI") - (concatenate - 'string "\"resourceRef\":" - (let ((inner-value - (let ((ref-topic (when (and (> (length value) 0) - (eql (elt value 0) #\#)) - (get-item-by-id (subseq value 1) :xtm-id xtm-id)))) - (if ref-topic - (concatenate 'string "#" (topic-id ref-topic)) - value)))) - (json:encode-json-to-string inner-value)) - ",\"resourceData\":null") - (concatenate 'string "\"resourceRef\":null," - "\"resourceData\":{\"datatype\":" - (json:encode-json-to-string datatype) - ",\"value\":" - (json:encode-json-to-string value) "}"))) + (concat "\"resourceRef\":" + (let ((inner-value + (let ((ref-topic + (when (and (> (length value) 0) + (eql (elt value 0) #\#)) + (get-item-by-id (subseq value 1) :xtm-id xtm-id)))) + (if ref-topic + (concat "#" (topic-id ref-topic)) + value)))) + (json:encode-json-to-string inner-value)) + ",\"resourceData\":null") + (concat "\"resourceRef\":null," + "\"resourceData\":{\"datatype\":" + (json:encode-json-to-string datatype) + ",\"value\":" + (json:encode-json-to-string value) "}"))) (defun ref-topics-to-json-string (topics &key (revision *TM-REVISION*)) @@ -82,13 +81,12 @@ "returns a json string of the type of the passed parent-elem" (declare (TypableC parent-elem) (type (or integer null) revision)) - (concatenate - 'string "\"type\":" - (if (instance-of parent-elem :revision revision) - (json:encode-json-to-string - (map 'list #'uri (psis (instance-of parent-elem :revision revision) - :revision revision))) - "null"))) + (concat "\"type\":" + (if (instance-of parent-elem :revision revision) + (json:encode-json-to-string + (map 'list #'uri (psis (instance-of parent-elem :revision revision) + :revision revision))) + "null"))) (defmethod to-json-string ((instance VariantC) &key (xtm-id d:*current-xtm*) @@ -97,15 +95,13 @@ (declare (type (or string null) xtm-id) (type (or integer null) revision)) (let ((itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (scope - (concatenate - 'string "\"scopes\":" (ref-topics-to-json-string - (themes instance :revision revision) - :revision revision))) + (concat "\"scopes\":" (ref-topics-to-json-string + (themes instance :revision revision) + :revision revision))) (resourceX (let ((value (when (slot-boundp instance 'charvalue) @@ -114,7 +110,7 @@ (when (slot-boundp instance 'datatype) (datatype instance)))) (resourceX-to-json-string value type :xtm-id xtm-id)))) - (concatenate 'string "{" itemIdentity "," scope "," resourceX "}"))) + (concat "{" itemIdentity "," scope "," resourceX "}"))) (defmethod to-json-string ((instance NameC) &key (xtm-id d:*current-xtm*) @@ -123,40 +119,34 @@ (declare (type (or string null) xtm-id) (type (or integer null) revision)) (let ((itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type (type-to-json-string instance :revision revision)) (scope - (concatenate - 'string "\"scopes\":" - (ref-topics-to-json-string (themes instance :revision revision) - :revision revision))) + (concat "\"scopes\":" + (ref-topics-to-json-string (themes instance :revision revision) + :revision revision))) (value - (concatenate 'string "\"value\":" - (if (slot-boundp instance 'charvalue) - (json:encode-json-to-string (charvalue instance)) - "null"))) + (concat "\"value\":" + (if (slot-boundp instance 'charvalue) + (json:encode-json-to-string (charvalue instance)) + "null"))) (variant (if (variants instance :revision revision) - (concatenate - 'string "\"variants\":" + (concat + "\"variants\":" (let ((j-variants "[")) (loop for variant in (variants instance :revision revision) - do (setf j-variants - (concatenate - 'string j-variants - (json-exporter::to-json-string variant :xtm-id xtm-id - :revision revision) - ","))) - (concatenate - 'string (subseq j-variants 0 - (- (length j-variants) 1)) "]"))) - (concatenate 'string "\"variants\":null")))) - (concatenate 'string "{" itemIdentity "," type "," scope "," value - "," variant "}"))) + do (push-string + (concat (json-exporter::to-json-string + variant :xtm-id xtm-id :revision revision) + ",") + j-variants)) + (concat (subseq j-variants 0 (- (length j-variants) 1)) "]"))) + (concat "\"variants\":null")))) + (concat "{" itemIdentity "," type "," scope "," value "," variant "}"))) (defmethod to-json-string ((instance OccurrenceC) &key (xtm-id d:*current-xtm*) @@ -165,17 +155,15 @@ (declare (type (or string null) xtm-id) (type (or integer null) revision)) (let ((itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type (type-to-json-string instance :revision revision)) (scope - (concatenate - 'string "\"scopes\":" - (ref-topics-to-json-string (themes instance :revision revision) - :revision revision))) + (concat "\"scopes\":" + (ref-topics-to-json-string (themes instance :revision revision) + :revision revision))) (resourceX (let ((value (when (slot-boundp instance 'charvalue) @@ -184,7 +172,7 @@ (when (slot-boundp instance 'datatype) (datatype instance)))) (resourceX-to-json-string value type :xtm-id xtm-id)))) - (concatenate 'string "{" itemIdentity "," type "," scope "," resourceX "}"))) + (concat "{" itemIdentity "," type "," scope "," resourceX "}"))) (defmethod to-json-string ((instance TopicC) &key (xtm-id d:*current-xtm*) @@ -193,59 +181,51 @@ (declare (type (or string null) xtm-id) (type (or integer null) revision)) (let ((id - (concatenate - 'string "\"id\":" - (json:encode-json-to-string (topic-id instance revision)))) + (concat "\"id\":" + (json:encode-json-to-string (topic-id instance revision)))) (itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (subjectLocator - (concatenate - 'string "\"subjectLocators\":" - (identifiers-to-json-string instance :what 'locators - :revision revision))) + (concat "\"subjectLocators\":" + (identifiers-to-json-string instance :what 'locators + :revision revision))) (subjectIdentifier - (concatenate - 'string "\"subjectIdentifiers\":" - (identifiers-to-json-string instance :what 'psis - :revision revision))) + (concat "\"subjectIdentifiers\":" + (identifiers-to-json-string instance :what 'psis + :revision revision))) (instanceOf - (concatenate - 'string "\"instanceOfs\":" - (ref-topics-to-json-string (list-instanceOf instance :revision revision) - :revision revision))) + (concat "\"instanceOfs\":" + (ref-topics-to-json-string + (list-instanceOf instance :revision revision) + :revision revision))) (name - (concatenate - 'string "\"names\":" - (if (names instance :revision revision) - (let ((j-names "[")) - (loop for item in (names instance :revision revision) - do (setf j-names - (concatenate - 'string j-names (to-json-string item :xtm-id xtm-id - :revision revision) - ","))) - (concatenate 'string (subseq j-names 0 (- (length j-names) 1)) "]")) - "null"))) + (concat "\"names\":" + (if (names instance :revision revision) + (let ((j-names "[")) + (loop for item in (names instance :revision revision) + do (push-string + (concat (to-json-string item :xtm-id xtm-id + :revision revision) ",") + j-names)) + (concat (subseq j-names 0 (- (length j-names) 1)) "]")) + "null"))) (occurrence - (concatenate - 'string "\"occurrences\":" + (concat + "\"occurrences\":" (if (occurrences instance :revision revision) (let ((j-occurrences "[")) (loop for item in (occurrences instance :revision revision) - do (setf j-occurrences - (concatenate - 'string j-occurrences - (to-json-string item :xtm-id xtm-id :revision revision) - ","))) - (concatenate - 'string (subseq j-occurrences 0 (- (length j-occurrences) 1)) "]")) + do (push-string + (concat + (to-json-string item :xtm-id xtm-id :revision revision) + ",") + j-occurrences)) + (concat (subseq j-occurrences 0 (- (length j-occurrences) 1)) "]")) "null")))) - (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," - subjectIdentifier "," - instanceOf "," name "," occurrence "}"))) + (concat "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier "," + instanceOf "," name "," occurrence "}"))) (defun to-json-topicStub-string (topic &key (revision *TM-REVISION*)) @@ -257,24 +237,19 @@ (type (or integer null) revision)) (when topic (let ((id - (concatenate - 'string "\"id\":" - (json:encode-json-to-string (topic-id topic revision)))) + (concat "\"id\":" + (json:encode-json-to-string (topic-id topic revision)))) (itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string topic :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string topic :what 'item-identifiers + :revision revision))) (subjectLocator - (concatenate - 'string "\"subjectLocators\":" - (identifiers-to-json-string topic :what 'locators :revision revision))) + (concat "\"subjectLocators\":" + (identifiers-to-json-string topic :what 'locators :revision revision))) (subjectIdentifier - (concatenate - 'string "\"subjectIdentifiers\":" - (identifiers-to-json-string topic :what 'psis :revision revision)))) - (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," - subjectIdentifier "}")))) + (concat "\"subjectIdentifiers\":" + (identifiers-to-json-string topic :what 'psis :revision revision)))) + (concat "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier "}")))) (defmethod to-json-string ((instance RoleC) &key (xtm-id d:*current-xtm*) @@ -283,52 +258,46 @@ (declare (ignorable xtm-id) (type (or integer null) revision)) (let ((itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type (type-to-json-string instance :revision revision)) (topicRef - (concatenate - 'string "\"topicRef\":" - (if (player instance :revision revision) - (json:encode-json-to-string - (map 'list #'uri (psis (player instance :revision revision) - :revision revision))) - "null")))) - (concatenate 'string "{" itemIdentity "," type "," topicRef "}"))) + (concat "\"topicRef\":" + (if (player instance :revision revision) + (json:encode-json-to-string + (map 'list #'uri (psis (player instance :revision revision) + :revision revision))) + "null")))) + (concat "{" itemIdentity "," type "," topicRef "}"))) (defmethod to-json-string ((instance AssociationC) &key (xtm-id d:*current-xtm*) (revision *TM-REVISION*)) "transforms an AssociationC object to a json string" (let ((itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string instance :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string instance :what 'item-identifiers + :revision revision))) (type (type-to-json-string instance :revision revision)) (scope - (concatenate - 'string "\"scopes\":" - (ref-topics-to-json-string (themes instance :revision revision) - :revision revision))) + (concat "\"scopes\":" + (ref-topics-to-json-string (themes instance :revision revision) + :revision revision))) (role - (concatenate - 'string "\"roles\":" - (if (roles instance :revision revision) - (let ((j-roles "[")) - (loop for item in (roles instance :revision revision) - do (setf j-roles - (concatenate - 'string j-roles (to-json-string item :xtm-id xtm-id - :revision revision) - ","))) - (concatenate 'string (subseq j-roles 0 (- (length j-roles) 1)) "]")) - "null")))) - (concatenate 'string "{" itemIdentity "," type "," scope "," role "}"))) + (concat "\"roles\":" + (if (roles instance :revision revision) + (let ((j-roles "[")) + (loop for item in (roles instance :revision revision) + do (push-string + (concat (to-json-string item :xtm-id xtm-id + :revision revision) ",") + j-roles)) + (concat (subseq j-roles 0 (- (length j-roles) 1)) "]")) + "null")))) + (concat "{" itemIdentity "," type "," scope "," role "}"))) (defmethod to-json-string ((instance TopicMapC) &key (xtm-id d:*current-xtm*) @@ -349,47 +318,40 @@ (declare (type (or string null) xtm-id) (type (or integer null) revision)) (let ((main-topic - (concatenate - 'string "\"topic\":" - (to-json-string (topic instance) :xtm-id xtm-id :revision revision))) + (concat "\"topic\":" + (to-json-string (topic instance) :xtm-id xtm-id :revision revision))) (topicStubs - (concatenate - 'string "\"topicStubs\":" - (if (referenced-topics instance) - (let ((j-topicStubs "[")) - (loop for item in (referenced-topics instance) - do (setf j-topicStubs - (concatenate - 'string j-topicStubs - (to-json-topicStub-string item :revision revision) - ","))) - (concatenate - 'string (subseq j-topicStubs 0 (- (length j-topicStubs) 1)) "]")) - "null"))) + (concat "\"topicStubs\":" + (if (referenced-topics instance) + (let ((j-topicStubs "[")) + (loop for item in (referenced-topics instance) + do (push-string + (concat (to-json-topicStub-string item :revision revision) + ",") + j-topicStubs)) + (concat (subseq j-topicStubs 0 (- (length j-topicStubs) 1)) "]")) + "null"))) (associations - (concatenate - 'string "\"associations\":" - (if (associations instance) - (let ((j-associations "[")) - (loop for item in (associations instance) - do (setf j-associations - (concatenate 'string j-associations - (to-json-string item :xtm-id xtm-id - :revision revision) ","))) - (concatenate 'string (subseq j-associations 0 - (- (length j-associations) 1)) "]")) - "null"))) + (concat "\"associations\":" + (if (associations instance) + (let ((j-associations "[")) + (loop for item in (associations instance) + do (push-string + (concat (to-json-string item :xtm-id xtm-id + :revision revision) ",") + j-associations)) + (concat (subseq j-associations 0 + (- (length j-associations) 1)) "]")) + "null"))) (tm-ids - (concatenate - 'string "\"tmIds\":" - (let ((uris - (loop for tm in (in-topicmaps (topic instance)) - collect (map 'list #'d:uri - (item-identifiers tm :revision revision))))) - (concatenate 'string (json:encode-json-to-string - (remove-if #'null uris))))))) - (concatenate 'string "{" main-topic "," topicStubs "," associations - "," tm-ids "}"))) + (concat "\"tmIds\":" + (let ((uris + (loop for tm in (in-topicmaps (topic instance)) + collect (when (item-identifiers tm) + (uri (first (item-identifiers + tm :revision revision))))))) + (json:encode-json-to-string uris))))) + (concat "{" main-topic "," topicStubs "," associations "," tm-ids "}"))) ;; ============================================================================= @@ -418,45 +380,39 @@ (declare (TopicC topic) (type (or integer null) revision)) (let ((id - (concatenate 'string "\"id\":\"" (topic-id topic revision) "\"")) + (concat "\"id\":\"" (topic-id topic revision) "\"")) (itemIdentity - (concatenate - 'string "\"itemIdentities\":" - (identifiers-to-json-string topic :what 'item-identifiers - :revision revision))) + (concat "\"itemIdentities\":" + (identifiers-to-json-string topic :what 'item-identifiers + :revision revision))) (subjectLocator - (concatenate - 'string "\"subjectLocators\":" - (identifiers-to-json-string topic :what 'locators :revision revision))) + (concat "\"subjectLocators\":" + (identifiers-to-json-string topic :what 'locators :revision revision))) (subjectIdentifier - (concatenate - 'string "\"subjectIdentifiers\":" - (identifiers-to-json-string topic :what 'psis :revision revision))) + (concat "\"subjectIdentifiers\":" + (identifiers-to-json-string topic :what 'psis :revision revision))) (instanceOf - (concatenate - 'string "\"instanceOfs\":" - (ref-topics-to-json-string (list-instanceOf topic :revision revision) - :revision revision))) + (concat "\"instanceOfs\":" + (ref-topics-to-json-string (list-instanceOf topic :revision revision) + :revision revision))) (name - (concatenate - 'string "\"names\":" - (if (names topic :revision revision) - (json:encode-json-to-string - (loop for name in (names topic :revision revision) - when (slot-boundp name 'charvalue) - collect (charvalue name))) - "null"))) + (concat "\"names\":" + (if (names topic :revision revision) + (json:encode-json-to-string + (loop for name in (names topic :revision revision) + when (slot-boundp name 'charvalue) + collect (charvalue name))) + "null"))) (occurrence - (concatenate - 'string "\"occurrences\":" - (if (occurrences topic :revision revision) - (json:encode-json-to-string - (loop for occurrence in (occurrences topic :revision revision) - when (slot-boundp occurrence 'charvalue) - collect (charvalue occurrence))) - "null")))) - (concatenate 'string "{" id "," itemIdentity "," subjectLocator "," - subjectIdentifier "," instanceOf "," name "," occurrence "}"))) + (concat "\"occurrences\":" + (if (occurrences topic :revision revision) + (json:encode-json-to-string + (loop for occurrence in (occurrences topic :revision revision) + when (slot-boundp occurrence 'charvalue) + collect (charvalue occurrence))) + "null")))) + (concat "{" id "," itemIdentity "," subjectLocator "," subjectIdentifier + "," instanceOf "," name "," occurrence "}"))) (defun make-topic-summary (topic-list &key (revision *TM-REVISION*)) @@ -466,15 +422,12 @@ (if topic-list (let ((json-string (let ((inner-string nil)) - (concatenate - 'string - (loop for topic in topic-list - do (setf inner-string - (concatenate - 'string inner-string - (to-json-string-summary topic :revision revision) ",")))) + (loop for topic in topic-list + do (push-string + (concat (to-json-string-summary topic :revision revision) ",") + inner-string)) (subseq inner-string 0 (- (length inner-string) 1))))) - (concatenate 'string "[" json-string "]")) + (concat "[" json-string "]")) "null")) @@ -491,9 +444,8 @@ (let ((j-str "{")) (loop for entry in query-result do (push-string - (concatenate - 'string + (concat (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 + (concat (subseq j-str 0 (- (length j-str) 1)) "}"))))) \ No newline at end of file Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Wed Jan 5 18:37:15 2011 @@ -41,7 +41,7 @@ (let ((value (get-constraints-of-topic topics :treat-as treat-as :revision revision))) - (concatenate 'string "\"topicConstraints\":" value)))) + (concat "\"topicConstraints\":" value)))) (let ((available-associations (remove-duplicates (loop for topic in topics @@ -51,29 +51,22 @@ (topictype-p item associationtype associationtype-constraint nil revision)) (let ((associations-constraints - (concatenate - 'string "\"associationsConstraints\":" - (let ((inner-associations-constraints "[")) - (loop for available-association in available-associations - do (let ((value - (get-constraints-of-association - available-association :revision revision))) - (setf inner-associations-constraints - (concatenate 'string inner-associations-constraints - value ",")))) - (if (string= inner-associations-constraints "[") - (setf inner-associations-constraints "null") - (setf inner-associations-constraints - (concatenate - 'string - (subseq inner-associations-constraints 0 - (- (length inner-associations-constraints) 1)) - "]"))))))) - (let ((json-string - (concatenate 'string - "{" topic-constraints "," associations-constraints - "}"))) - json-string))))))) + (concat "\"associationsConstraints\":" + (let ((inner-associations-constraints "[")) + (loop for available-association in available-associations + do (let ((value + (get-constraints-of-association + available-association :revision revision))) + (push-string (concat value ",") + inner-associations-constraints))) + (if (string= inner-associations-constraints "[") + (setf inner-associations-constraints "null") + (setf inner-associations-constraints + (concat + (subseq inner-associations-constraints 0 + (- (length inner-associations-constraints) 1)) + "]"))))))) + (concat "{" topic-constraints "," associations-constraints "}"))))))) ;; ============================================================================= @@ -89,26 +82,26 @@ (get-all-constraint-topics-of-association associationtype-topic :revision revision))) (let ((associationtype - (concatenate 'string "\"associationType\":" - (json-exporter::identifiers-to-json-string - associationtype-topic :revision revision))) + (concat "\"associationType\":" + (json-exporter::identifiers-to-json-string + associationtype-topic :revision revision))) (associationtypescope-constraints (let ((value (get-typescope-constraints associationtype-topic :what 'association :revision revision))) - (concatenate 'string "\"scopeConstraints\":" value))) + (concat "\"scopeConstraints\":" value))) (associationrole-constraints (let ((value (get-associationrole-constraints (getf constraint-topics :associationrole-constraints) :revision revision))) - (concatenate 'string "\"associationRoleConstraints\":" value))) + (concat "\"associationRoleConstraints\":" value))) (roleplayer-constraints (let ((value (get-roleplayer-constraints (getf constraint-topics :roleplayer-constraints) :revision revision))) - (concatenate 'string "\"rolePlayerConstraints\":" value))) + (concat "\"rolePlayerConstraints\":" value))) (otherrole-constraints (let ((value (handler-case @@ -116,13 +109,10 @@ (getf constraint-topics :otherrole-constraints) :revision revision) (condition () "null")))) - (concatenate 'string "\"otherRoleConstraints\":" value)))) - (let ((json-string - (concatenate 'string "{" associationtype "," associationrole-constraints - "," roleplayer-constraints "," - otherrole-constraints "," associationtypescope-constraints - "}"))) - json-string)))) + (concat "\"otherRoleConstraints\":" value)))) + (concat "{" associationtype "," associationrole-constraints + "," roleplayer-constraints "," otherrole-constraints "," + associationtypescope-constraints "}")))) (defun get-otherrole-constraints (constraint-topics &key (revision *TM-REVISION*)) @@ -271,69 +261,66 @@ constraint-lists)) (let ((json-player-type - (concatenate - 'string "\"playerType\":" - (topics-to-json-list - (getf (list-subtypes (getf involved-topic-tupple :player) - nil nil nil nil revision) - :subtypes) :revision revision))) + (concat "\"playerType\":" + (topics-to-json-list + (getf (list-subtypes + (getf involved-topic-tupple :player) + nil nil nil nil revision) + :subtypes) :revision revision))) (json-player - (concatenate - 'string "\"players\":" - (topics-to-json-list - (list-instances (getf involved-topic-tupple :player) - topictype topictype-constraint revision) - :revision revision))) + (concat "\"players\":" + (topics-to-json-list + (list-instances + (getf involved-topic-tupple :player) + topictype topictype-constraint revision) + :revision revision))) (json-role - (concatenate - 'string "\"roleType\":" - (topics-to-json-list - (getf (list-subtypes (getf involved-topic-tupple :role) - roletype roletype-constraint nil - nil revision) - :subtypes) :revision revision))) + (concat "\"roleType\":" + (topics-to-json-list + (getf (list-subtypes + (getf involved-topic-tupple :role) + roletype roletype-constraint nil + nil revision) + :subtypes) :revision revision))) (json-otherplayer-type - (concatenate - 'string "\"otherPlayerType\":" - (topics-to-json-list - (getf (list-subtypes - (getf involved-topic-tupple :otherplayer) - nil nil nil nil revision) :subtypes) - :revision revision))) + (concat "\"otherPlayerType\":" + (topics-to-json-list + (getf (list-subtypes + (getf involved-topic-tupple :otherplayer) + nil nil nil nil revision) :subtypes) + :revision revision))) (json-otherplayer - (concatenate - 'string "\"otherPlayers\":" - (topics-to-json-list - (list-instances (getf involved-topic-tupple :otherplayer) - topictype topictype-constraint revision) - :revision revision))) + (concat "\"otherPlayers\":" + (topics-to-json-list + (list-instances + (getf involved-topic-tupple :otherplayer) + topictype topictype-constraint revision) + :revision revision))) (json-otherrole - (concatenate - 'string "\"otherRoleType\":" - (topics-to-json-list - (getf (list-subtypes - (getf involved-topic-tupple :otherrole) - roletype roletype-constraint nil nil revision) - :subtypes) :revision revision))) + (concat "\"otherRoleType\":" + (topics-to-json-list + (getf (list-subtypes + (getf involved-topic-tupple :otherrole) + roletype roletype-constraint nil nil revision) + :subtypes) :revision revision))) (card-min - (concatenate 'string "\"cardMin\":" - (getf (first constraint-lists) :card-min))) + (concat "\"cardMin\":" + (getf (first constraint-lists) :card-min))) (card-max - (concatenate 'string "\"cardMax\":" - (getf (first constraint-lists) :card-max)))) + (concat "\"cardMax\":" + (getf (first constraint-lists) :card-max)))) (setf cleaned-otherrole-constraints - (concatenate 'string cleaned-otherrole-constraints - "{" json-player-type "," json-player "," - json-role "," json-otherplayer-type "," - json-otherplayer "," json-otherrole "," - card-min "," card-max "},"))))) + (concat cleaned-otherrole-constraints + "{" json-player-type "," json-player "," + json-role "," json-otherplayer-type "," + json-otherplayer "," json-otherrole "," + card-min "," card-max "},"))))) (if (string= cleaned-otherrole-constraints "[") (setf cleaned-otherrole-constraints "null") (setf cleaned-otherrole-constraints - (concatenate - 'string (subseq cleaned-otherrole-constraints 0 - (- (length cleaned-otherrole-constraints) 1)) - "]"))) + (concat (subseq cleaned-otherrole-constraints 0 + (- (length cleaned-otherrole-constraints) 1)) + "]"))) cleaned-otherrole-constraints))))) @@ -442,47 +429,44 @@ :revision revision))) constraint-lists)) (let ((json-player-type - (concatenate - 'string "\"playerType\":" - (topics-to-json-list - (getf (list-subtypes (getf role-player-tupple :player) - nil nil nil nil revision) :subtypes) - :revision revision))) + (concat "\"playerType\":" + (topics-to-json-list + (getf (list-subtypes + (getf role-player-tupple :player) + nil nil nil nil revision) :subtypes) + :revision revision))) (json-players - (concatenate - 'string "\"players\":" - (topics-to-json-list - (list-instances (getf role-player-tupple :player) - topictype topictype-constraint revision) - :revision revision))) + (concat "\"players\":" + (topics-to-json-list + (list-instances + (getf role-player-tupple :player) + topictype topictype-constraint revision) + :revision revision))) (json-role - (concatenate - 'string "\"roleType\":" - (topics-to-json-list - (getf (list-subtypes (getf role-player-tupple :role) - roletype roletype-constraint nil - nil revision) - :subtypes) - :revision revision))) + (concat "\"roleType\":" + (topics-to-json-list + (getf (list-subtypes + (getf role-player-tupple :role) + roletype roletype-constraint nil + nil revision) + :subtypes) + :revision revision))) (card-min - (concatenate - 'string "\"cardMin\":" - (getf (first constraint-lists) :card-min))) + (concat "\"cardMin\":" + (getf (first constraint-lists) :card-min))) (card-max - (concatenate - 'string "\"cardMax\":" - (getf (first constraint-lists) :card-max)))) + (concat "\"cardMax\":" + (getf (first constraint-lists) :card-max)))) (setf cleaned-roleplayer-constraints - (concatenate 'string cleaned-roleplayer-constraints - "{" json-player-type "," json-players "," - json-role "," card-min "," card-max "},"))))) + (concat cleaned-roleplayer-constraints + "{" json-player-type "," json-players "," + json-role "," card-min "," card-max "},"))))) (if (string= cleaned-roleplayer-constraints "[") (setf cleaned-roleplayer-constraints "null") (setf cleaned-roleplayer-constraints - (concatenate - 'string (subseq cleaned-roleplayer-constraints 0 - (- (length cleaned-roleplayer-constraints) 1)) - "]"))) + (concat (subseq cleaned-roleplayer-constraints 0 + (- (length cleaned-roleplayer-constraints) 1)) + "]"))) cleaned-roleplayer-constraints))))) @@ -555,20 +539,18 @@ roletype roletype-constraint nil nil revision) :subtypes))))) (setf cleaned-associationrole-constraints - (concatenate 'string - cleaned-associationrole-constraints - "{\"roleType\":" roletype-with-subtypes - ",\"cardMin\":" (getf (first constraint-lists) - :card-min) - ",\"cardMax\":" (getf (first constraint-lists) - :card-max) "},"))))) + (concat cleaned-associationrole-constraints + "{\"roleType\":" roletype-with-subtypes + ",\"cardMin\":" (getf (first constraint-lists) + :card-min) + ",\"cardMax\":" (getf (first constraint-lists) + :card-max) "},"))))) (if (string= cleaned-associationrole-constraints "[") (setf cleaned-associationrole-constraints "null") (setf cleaned-associationrole-constraints - (concatenate - 'string (subseq cleaned-associationrole-constraints 0 - (- (length cleaned-associationrole-constraints) - 1)) "]"))) + (concat (subseq cleaned-associationrole-constraints 0 + (- (length cleaned-associationrole-constraints) + 1)) "]"))) cleaned-associationrole-constraints))))) @@ -627,51 +609,49 @@ (let ((value "[")) (loop for exclusive-instance-constraint in exclusive-instance-constraints do (setf value - (concatenate 'string value - (get-exclusive-instance-constraints - (first exclusive-instance-constraint) - (second exclusive-instance-constraint) - :revision revision) ","))) + (concat value (get-exclusive-instance-constraints + (first exclusive-instance-constraint) + (second exclusive-instance-constraint) + :revision revision) ","))) (if (string= value "[") (setf value "null") - (setf value (concatenate 'string (subseq value 0 - (- (length value) 1)) "]"))) - (concatenate 'string "\"exclusiveInstances\":" value))) + (setf value (concat (subseq value 0 (- (length value) 1)) "]"))) + (concat "\"exclusiveInstances\":" value))) (subjectidentifier-constraints (let ((value (get-simple-constraints subjectidentifier-constraints :error-msg-constraint-name "subjectidentifier" :revision revision))) - (concatenate 'string "\"subjectIdentifierConstraints\":" value))) + (concat "\"subjectIdentifierConstraints\":" value))) (subjectlocator-constraints (let ((value (get-simple-constraints subjectlocator-constraints :error-msg-constraint-name "subjectlocator" :revision revision))) - (concatenate 'string "\"subjectLocatorConstraints\":" value))) + (concat "\"subjectLocatorConstraints\":" value))) (topicname-constraints (let ((value (get-topicname-constraints topicname-constraints :revision revision))) - (concatenate 'string "\"topicNameConstraints\":" value))) + (concat "\"topicNameConstraints\":" value))) (topicoccurrence-constraints (let ((value (get-topicoccurrence-constraints topicoccurrence-constraints uniqueoccurrence-constraints :revision revision))) - (concatenate 'string "\"topicOccurrenceConstraints\":" value))) + (concat "\"topicOccurrenceConstraints\":" value))) (abstract-constraint - (concatenate 'string "\"abstractConstraint\":" - (if abstract-topictype-constraints - "true" - "false")))) + (concat "\"abstractConstraint\":" + (if abstract-topictype-constraints + "true" + "false")))) (let ((json-string - (concatenate 'string "{" exclusive-instance-constraints "," - subjectidentifier-constraints - "," subjectlocator-constraints "," topicname-constraints "," - topicoccurrence-constraints "," abstract-constraint "}"))) + (concat "{" exclusive-instance-constraints "," + subjectidentifier-constraints "," subjectlocator-constraints + "," topicname-constraints "," topicoccurrence-constraints + "," abstract-constraint "}"))) json-string)))) @@ -721,15 +701,15 @@ (player other-role :revision revision) topictype topictype-constraint nil nil revision) :subtypes))))))))) - (concatenate 'string "{\"owner\":" (json-exporter::identifiers-to-json-string - owner :revision revision) - ",\"exclusives\":" - (json:encode-json-to-string - (map 'list #'(lambda(y) - (map 'list #'uri y)) - (map 'list #'(lambda(z) - (psis z :revision revision)) - topics))) "}")))) + (concat "{\"owner\":" (json-exporter::identifiers-to-json-string + owner :revision revision) + ",\"exclusives\":" + (json:encode-json-to-string + (map 'list #'(lambda(y) + (map 'list #'uri y)) + (map 'list #'(lambda(z) + (psis z :revision revision)) + topics))) "}")))) (defun get-simple-constraints(constraint-topics &key @@ -763,21 +743,19 @@ (let ((constraints "[")) (loop for constraint in simple-constraints do (let ((constraint - (concatenate - 'string "{\"regexp\":" - (json:encode-json-to-string (getf constraint :regexp)) - ",\"cardMin\":" - (json:encode-json-to-string (getf constraint :card-min)) - ",\"cardMax\":" - (json:encode-json-to-string (getf constraint :card-max)) - "}"))) + (concat "{\"regexp\":" + (json:encode-json-to-string (getf constraint :regexp)) + ",\"cardMin\":" + (json:encode-json-to-string (getf constraint :card-min)) + ",\"cardMax\":" + (json:encode-json-to-string (getf constraint :card-max)) + "}"))) (if (string= constraints "[") - (setf constraints (concatenate 'string constraints constraint)) - (setf constraints (concatenate 'string constraints "," constraint))))) + (push-string constraint constraints) + (push-string (concat "," constraint) constraints)))) (if (string= constraints "[") - (setf constraints "null") - (setf constraints (concatenate 'string constraints "]"))) - constraints)) + "null" + (concat constraints "]")))) (defun get-topicname-constraints(constraint-topics &key (revision *TM-REVISION*)) @@ -850,8 +828,8 @@ (let ((nametypescopes "\"nametypescopes\":[")) (loop for current-topic in nametype-with-subtypes do (let ((current-json-string - (concatenate - 'string "{\"nameType\":" + (concat + "{\"nameType\":" (json-exporter::identifiers-to-json-string current-topic :revision revision) ",\"scopeConstraints\":" @@ -859,30 +837,25 @@ :what 'topicname :revision revision) "}"))) - (setf nametypescopes - (concatenate 'string nametypescopes - current-json-string ",")))) + (push-string (concat current-json-string ",") + nametypescopes))) (if (string= nametypescopes "\"nametypescopes\"[") (setf nametypescopes "null") (setf nametypescopes - (concatenate - 'string (subseq nametypescopes 0 - (- (length nametypescopes) 1)) "]"))) + (concat (subseq nametypescopes 0 + (- (length nametypescopes) 1)) "]"))) (let ((json-constraint-lists - (concatenate - 'string "\"constraints\":" - (simple-constraints-to-json constraint-lists)))) + (concat "\"constraints\":" + (simple-constraints-to-json constraint-lists)))) (setf cleaned-topicname-constraints - (concatenate - 'string cleaned-topicname-constraints "{" - nametypescopes "," json-constraint-lists "},"))))))) + (concat cleaned-topicname-constraints "{" + nametypescopes "," json-constraint-lists "},"))))))) (if (string= cleaned-topicname-constraints "[") (setf cleaned-topicname-constraints "null") (setf cleaned-topicname-constraints - (concatenate - 'string (subseq cleaned-topicname-constraints 0 - (- (length cleaned-topicname-constraints) 1)) - "]"))) + (concat (subseq cleaned-topicname-constraints 0 + (- (length cleaned-topicname-constraints) 1)) + "]"))) cleaned-topicname-constraints))))) @@ -963,51 +936,43 @@ (let ((occurrencetypes-json-string "\"occurrenceTypes\":[")) (loop for current-topic in occurrencetype-with-subtypes do (let ((current-json-string - (concatenate - 'string "{\"occurrenceType\":" - (json-exporter::identifiers-to-json-string - current-topic :revision revision) - ",\"scopeConstraints\":" - (get-typescope-constraints - current-topic :what 'topicoccurrence - :revision revision) - ",\"datatypeConstraint\":" - (get-occurrence-datatype-constraint - current-topic :revision revision) - "}"))) - (setf occurrencetypes-json-string - (concatenate 'string occurrencetypes-json-string - current-json-string ",")))) + (concat "{\"occurrenceType\":" + (json-exporter::identifiers-to-json-string + current-topic :revision revision) + ",\"scopeConstraints\":" + (get-typescope-constraints + current-topic :what 'topicoccurrence + :revision revision) + ",\"datatypeConstraint\":" + (get-occurrence-datatype-constraint + current-topic :revision revision) + "}"))) + (push-string (concat current-json-string ",") + occurrencetypes-json-string))) (if (string= occurrencetypes-json-string "\"occurrenceTypes\"[") (setf occurrencetypes-json-string "null") (setf occurrencetypes-json-string - (concatenate - 'string (subseq occurrencetypes-json-string 0 - (- (length - occurrencetypes-json-string) 1)) - "]"))) + (concat (subseq occurrencetypes-json-string 0 + (- (length + occurrencetypes-json-string) 1)) + "]"))) (let ((unique-constraints - (concatenate 'string "\"uniqueConstraints\":" - (get-simple-constraints - unique-constraint-topics - :revision revision))) + (concat "\"uniqueConstraints\":" + (get-simple-constraints unique-constraint-topics + :revision revision))) (json-constraint-lists - (concatenate - 'string "\"constraints\":" - (simple-constraints-to-json constraint-lists)))) + (concat "\"constraints\":" + (simple-constraints-to-json constraint-lists)))) (let ((current-json-string - (concatenate - 'string "{" occurrencetypes-json-string "," - json-constraint-lists "," unique-constraints "}"))) - (setf cleaned-topicoccurrence-constraints - (concatenate - 'string cleaned-topicoccurrence-constraints - current-json-string ",")))))))) + (concat "{" occurrencetypes-json-string "," + json-constraint-lists "," + unique-constraints "}"))) + (push-string (concat current-json-string ",") + cleaned-topicoccurrence-constraints))))))) (if (string= cleaned-topicoccurrence-constraints "[") (setf cleaned-topicoccurrence-constraints "null") (setf cleaned-topicoccurrence-constraints - (concatenate - 'string + (concat (subseq cleaned-topicoccurrence-constraints 0 (- (length cleaned-topicoccurrence-constraints) 1)) "]"))) @@ -1185,8 +1150,8 @@ (let ((card-min (getf (first constraint-lists) :card-min)) (card-max (getf (first constraint-lists) :card-max))) (let ((json-scopes - (concatenate - 'string "\"scopeTypes\":" + (concat + "\"scopeTypes\":" (let ((scopetypes-with-subtypes (remove-if #'null @@ -1207,17 +1172,15 @@ topic-group)) scopetypes-with-subtypes)))))) (let ((current-json-string - (concatenate 'string "{" json-scopes - ",\"cardMin\":\"" card-min - "\",\"cardMax\":\"" card-max "\"}"))) - (setf cleaned-typescope-constraints - (concatenate 'string cleaned-typescope-constraints - current-json-string ","))))))) + (concat "{" json-scopes + ",\"cardMin\":\"" card-min + "\",\"cardMax\":\"" card-max "\"}"))) + (push-string (concat current-json-string ",") + cleaned-typescope-constraints)))))) (if (string= cleaned-typescope-constraints "[") (setf cleaned-typescope-constraints "null") (setf cleaned-typescope-constraints - (concatenate - 'string + (concat (subseq cleaned-typescope-constraints 0 (- (length cleaned-typescope-constraints) 1)) "]"))) cleaned-typescope-constraints))))))) @@ -1725,16 +1688,14 @@ (defun tree-view-to-json-string (tree-views) "Returns a full tree-view as json-string." (let ((json-string - (concatenate - 'string "[" + (concat + "[" (if tree-views (let ((inner-string "")) (loop for tree-view in tree-views - do (setf inner-string - (concatenate 'string inner-string - (node-to-json-string tree-view) ","))) - (concatenate 'string (subseq inner-string 0 - (- (length inner-string) 1)) "]")) + do (push-string (concat (node-to-json-string tree-view) ",") + inner-string)) + (concat (subseq inner-string 0 (- (length inner-string) 1)) "]")) "null")))) json-string)) @@ -1784,50 +1745,46 @@ (declare (type (or integer null) revision) (list node)) (let ((topic-psis - (concatenate - 'string "\"topic\":" + (concat + "\"topic\":" (json:encode-json-to-string (map 'list #'d:uri (d:psis (getf node :topic) :revision revision))))) (is-type - (concatenate 'string "\"isType\":" - (if (getf node :is-type) - "true" - "false"))) + (concat "\"isType\":" (if (getf node :is-type) + "true" + "false"))) (is-instance - (concatenate 'string "\"isInstance\":" - (if (getf node :is-instance) - "true" - "false"))) + (concat "\"isInstance\":" (if (getf node :is-instance) + "true" + "false"))) (instances - (concatenate - 'string "\"instances\":" + (concat + "\"instances\":" (if (getf node :instances) (let ((inner-string "[")) (loop for instance-node in (getf node :instances) do (setf inner-string - (concatenate - 'string inner-string + (concat + inner-string (node-to-json-string instance-node :revision revision) ","))) - (concatenate 'string (subseq inner-string 0 - (- (length inner-string) 1)) "]")) + (concat (subseq inner-string 0 (- (length inner-string) 1)) "]")) "null"))) (subtypes - (concatenate - 'string "\"subtypes\":" + (concat + "\"subtypes\":" (if (getf node :subtypes) (let ((inner-string "[")) (loop for instance-node in (getf node :subtypes) - do (setf inner-string - (concatenate 'string inner-string - (node-to-json-string instance-node - :revision revision) - ","))) - (concatenate 'string (subseq inner-string 0 - (- (length inner-string) 1)) "]")) + do (push-string (concat + (node-to-json-string instance-node + :revision revision) + ",") + inner-string)) + (concat (subseq inner-string 0 (- (length inner-string) 1)) "]")) "null")))) - (concatenate 'string "{" topic-psis "," is-type "," is-instance "," instances - "," subtypes"}"))) + (concat "{" topic-psis "," is-type "," is-instance "," instances + "," subtypes"}"))) (defun make-nodes (topic-instance is-type is-instance &key (revision *TM-REVISION*)) Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Wed Jan 5 18:37:15 2011 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :json-tmcl - (:use :cl :datamodel :constants :json-tmcl-constants :json-importer) + (:use :cl :datamodel :constants :json-tmcl-constants :json-importer :base-tools) (:export :get-constraints-of-fragment :topictype-p :abstract-p Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Wed Jan 5 18:37:15 2011 @@ -1634,7 +1634,7 @@ (unless possible-identifiers (error (make-object-not-found-condition (format nil "Could not find an object ~a in xtm-id ~a" construct xtm-id)))) (uri (first possible-identifiers))) - (concatenate 'string "t" (write-to-string (internal-id construct)))))) + (concat "t" (write-to-string (internal-id construct)))))) (defgeneric topic-identifiers (construct &key revision) Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Wed Jan 5 18:37:15 2011 @@ -21,6 +21,7 @@ :xml-importer :json-exporter :json-importer + :base-tools :isidorus-threading) (:export :import-fragments-feed :import-snapshots-feed 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 Wed Jan 5 18:37:15 2011 @@ -532,37 +532,14 @@ (let ((last-position-of-current-path (- (length current-path-string) 1))) (let ((current-url - (concatenate - 'string url-prefix + (concat + url-prefix (subseq current-path-string start-position-of-relative-path last-position-of-current-path)))) (push (list :path current-path :url current-url) files-and-urls)))))) files-and-urls))) -(defun string-replace (str search-str replace-str) - "replaces all sub-strings in str of the form search-str with - the string replace-str and returns the new generated string" - (if (= (length search-str) 0) - str - (progn - (let ((ret-str "") - (idx 0)) - (loop - (if (string= str search-str - :start1 idx - :end1 (min (length str) - (+ idx (length search-str)))) - (progn - (setf ret-str (concatenate 'string ret-str replace-str)) - (incf idx (length search-str))) - (progn - (setf ret-str (concatenate 'string ret-str (subseq str idx (1+ idx)))) - (incf idx))) - (unless (< idx (length str)) - (return ret-str))))))) - - (defun init-cache() "Initializes the type and instance cache-tables with all valid types/instances" (with-writer-lock Modified: trunk/src/unit_tests/datamodel_test.lisp ============================================================================== --- trunk/src/unit_tests/datamodel_test.lisp (original) +++ trunk/src/unit_tests/datamodel_test.lisp Wed Jan 5 18:37:15 2011 @@ -13,6 +13,7 @@ :datamodel :it.bese.FiveAM :fixtures + :base-tools :unittests-constants) (:import-from :exceptions duplicate-identifier-error @@ -481,12 +482,10 @@ :revision rev-0))) (is (eql top-3 (get-item-by-id - (concatenate 'string "t" (write-to-string - (elephant::oid top-3))) + (concat "t" (write-to-string (elephant::oid top-3))) :revision rev-0 :xtm-id nil))) (is-false (get-item-by-id - (concatenate 'string "t" (write-to-string - (elephant::oid top-3))) + (concat "t" (write-to-string (elephant::oid top-3))) :revision rev-1 :xtm-id nil))))) Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Wed Jan 5 18:37:15 2011 @@ -14,6 +14,7 @@ :json-exporter :json-importer :json-tmcl + :base-tools :datamodel :it.bese.FiveAM :unittests-constants @@ -86,28 +87,28 @@ (let ((t50a (get-item-by-id "t50a" :xtm-id *TEST-TM* :revision rev-0))) (let ((t50a-string (to-json-string t50a :revision 0)) (json-string - (concatenate 'string "{\"id\":\"" (topic-id t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" ))) + (concat "{\"id\":\"" (topic-id t50a) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t50a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/occurrence-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"long version of a name\",\"variants\":[{\"itemIdentities\":null,\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Long-Version\"}}]}],\"occurrences\":null}" ))) (is (string= t50a-string json-string))) (let ((t8 (get-item-by-id "t8" :revision rev-0 :xtm-id *TEST-TM*))) (let ((t8-string (to-json-string t8 :revision rev-0 :xtm-id *TEST-TM*)) (json-string - (concatenate 'string "{\"id\":\"" (topic-id t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}"))) + (concat "{\"id\":\"" (topic-id t8) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t8\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/association-role-type\"],\"instanceOfs\":[[\"http:\\/\\/www.networkedplanet.com\\/psi\\/npcl\\/meta-types\\/topic-type\"]],\"names\":[{\"itemIdentities\":null,\"type\":null,\"scopes\":null,\"value\":\"Association Role Type\",\"variants\":null}],\"occurrences\":null}"))) (is (string= t8-string json-string)))) (let ((t-topic (get-item-by-id "topic" :xtm-id "core.xtm" :revision rev-0))) (let ((t-topic-string (to-json-string t-topic :xtm-id "core.xtm" :revision rev-0)) (json-string - (concatenate 'string "{\"id\":\"" (topic-id t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}"))) + (concat "{\"id\":\"" (topic-id t-topic) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null}"))) (is (string= t-topic-string json-string)))) (let ((t301 (get-item-by-id "t301" :xtm-id *TEST-TM* :revision rev-0))) (let ((t301-string (to-json-string t301 :xtm-id *TEST-TM* :revision rev-0)) (json-string - (concatenate 'string "{\"id\":\"" (topic-id t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}"))) + (concat "{\"id\":\"" (topic-id t301) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/service\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/topic\\/t301a_n1\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps\",\"variants\":null},{\"itemIdentities\":null,\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/long-name\"]],\"value\":\"Google Maps Application\",\"variants\":null}],\"occurrences\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"a popular geodata service that is widely used for mashups with geodataProbably not really conformant to ISO 19115, but who cares in this context.\"}},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.com\",\"resourceData\":null},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/maps.google.de\",\"resourceData\":null}]}"))) (is (string= t301-string json-string)))) (let ((t100 (get-item-by-id "t100" :revision rev-0 :xtm-id *TEST-TM*))) (let ((t100-string (to-json-string t100 :revision rev-0 :xtm-id *TEST-TM*)) (json-string - (concatenate 'string "{\"id\":\"" (topic-id t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}"))) + (concat "{\"id\":\"" (topic-id t100) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]}"))) (is (string= t100-string json-string)))))))) @@ -152,12 +153,12 @@ (let ((association-1-string (to-json-string association-1 :revision rev-0 :xtm-id *TEST-TM*)) (json-string - (concatenate 'string "{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/isNarrowerSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/broaderSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Data\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/narrowerSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]}"))) + (concat "{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/isNarrowerSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/broaderSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Data\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/narrowerSubject\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]}"))) (is (string= association-1-string json-string))) (let ((association-7-string (to-json-string association-7 :revision rev-0 :xtm-id *TEST-TM*)) (json-string - (concatenate 'string "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}"))) + (concat "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}"))) (is (string= association-7-string json-string))) (let ((rev-1 (get-revision))) (delete-role association-7 (first (roles association-7 :revision 0)) @@ -171,7 +172,7 @@ (let ((association-7-string (to-json-string association-7 :revision rev-0 :xtm-id *TEST-TM*)) (json-string - (concatenate 'string "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]],\"roles\":null}"))) + (concat "{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":null,\"scopes\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]],\"roles\":null}"))) (is (string= association-7-string json-string)))))))) @@ -189,9 +190,9 @@ (frag-topic (create-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#topic"))) (let ((frag-t100-string - (concatenate 'string "{\"topic\":{\"id\":\"" (d:topic-id (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}")) + (concat "{\"topic\":{\"id\":\"" (d:topic-id (d:topic frag-t100)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"],\"instanceOfs\":[[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o1\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.budabe.de\\/\",\"resourceData\":null},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o2\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o3\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t100_o4\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"],\"scopes\":null,\"resourceRef\":\"http:\\/\\/www.editeur.org\\/standards\\/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/semanticstandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#display\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#sort\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardHasStatus\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardValidFromDate\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/links\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"id\":\"" (topic-id (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/SubjectRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/subject\\/Semantic+Description\"]}]},{\"itemIdentities\":[\"http:\\/\\/psi.egovpt.org\\/itemIdentifiers#assoc_7\"],\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/ServiceRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/service\\/Google+Maps\",\"http:\\/\\/maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http:\\/\\/psi.egovpt.org\\/types\\/StandardRoleType\"],\"topicRef\":[\"http:\\/\\/psi.egovpt.org\\/standard\\/ISO+19115%3A+Geographic+Information+-+Metadata\"]}]}],\"tmIds\":[\"http:\\/\\/www.isidor.us\\/unittests\\/testtm\"]}")) (frag-topic-string - (concatenate 'string "{\"topic\":{\"id\":\"" (topic-id (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}"))) + (concat "{\"topic\":{\"id\":\"" (topic-id (topic frag-topic)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm#topic\"],\"instanceOfs\":null,\"names\":null,\"occurrences\":null},\"topicStubs\":null,\"associations\":null,\"tmIds\":[\"http:\\/\\/www.topicmaps.org\\/xtm\\/1.0\\/core.xtm\"]}"))) (is (string= frag-t100-string (to-json-string frag-t100 :xtm-id *TEST-TM* :revision rev-0))) @@ -331,7 +332,7 @@ "http://psi.egovpt.org/types/standardHasStatus")) (is-false (getf occurrence-1 :scopes)) (is (string= (getf occurrence-1 :resourceRef) - (concatenate 'string "#" (d:topic-id ref-topic)))) + (concat "#" (d:topic-id ref-topic)))) (is-false (getf occurrence-1 :resourceData)) (is-false (getf occurrence-2 :itemIdentities)) (is (= (length (getf occurrence-2 :type)) 1)) @@ -1649,11 +1650,11 @@ :start-revision rev-1 :psis (list (make-construct 'PersistentIdC :uri "nScope-2"))))) - (let ((j-req-1 (concatenate 'string j-type j-parent-1 j-name-1)) - (j-req-2 (concatenate 'string j-type j-parent-1 j-name-2)) - (j-req-3 (concatenate 'string j-type j-parent-1 j-name-3)) - (j-req-4 (concatenate 'string j-type j-parent-2 j-name-1)) - (j-req-5 (concatenate 'string j-type j-parent-2 j-name-2)) + (let ((j-req-1 (concat j-type j-parent-1 j-name-1)) + (j-req-2 (concat j-type j-parent-1 j-name-2)) + (j-req-3 (concat j-type j-parent-1 j-name-3)) + (j-req-4 (concat j-type j-parent-2 j-name-1)) + (j-req-5 (concat j-type j-parent-2 j-name-2)) (top-1 (make-construct 'TopicC :start-revision rev-1 @@ -1751,11 +1752,11 @@ :start-revision rev-1 :psis (list (make-construct 'PersistentIdC :uri "oScope-2"))))) - (let ((j-req-1 (concatenate 'string j-type j-parent-1 j-occ-1)) - (j-req-2 (concatenate 'string j-type j-parent-1 j-occ-2)) - (j-req-3 (concatenate 'string j-type j-parent-1 j-occ-3)) - (j-req-4 (concatenate 'string j-type j-parent-2 j-occ-1)) - (j-req-5 (concatenate 'string j-type j-parent-2 j-occ-2)) + (let ((j-req-1 (concat j-type j-parent-1 j-occ-1)) + (j-req-2 (concat j-type j-parent-1 j-occ-2)) + (j-req-3 (concat j-type j-parent-1 j-occ-3)) + (j-req-4 (concat j-type j-parent-2 j-occ-1)) + (j-req-5 (concat j-type j-parent-2 j-occ-2)) (top-1 (make-construct 'TopicC :start-revision rev-1 @@ -1864,12 +1865,9 @@ :start-revision rev-1 :psis (list (make-construct 'PersistentIdC :uri "vScope-2"))))) - (let ((j-req-1 (concatenate 'string j-type j-parent-of-parent-1 - j-parent-1 j-var-1)) - (j-req-2 (concatenate 'string j-type j-parent-of-parent-1 - j-parent-1 j-var-2)) - (j-req-3 (concatenate 'string j-type j-parent-of-parent-1 - j-parent-2 j-var-1)) + (let ((j-req-1 (concat j-type j-parent-of-parent-1 j-parent-1 j-var-1)) + (j-req-2 (concat j-type j-parent-of-parent-1 j-parent-1 j-var-2)) + (j-req-3 (concat j-type j-parent-of-parent-1 j-parent-2 j-var-1)) (top-1 (make-construct 'TopicC :start-revision rev-1 @@ -1987,9 +1985,9 @@ (j-role-3 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-2\"]}") (rev-1 100) (rev-2 200)) - (let ((j-req-1 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) - (j-req-2 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) - (j-req-3 (concatenate 'string j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]}}")) + (let ((j-req-1 (concat j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) + (j-req-2 (concat j-type "\"delete\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "]}}")) + (j-req-3 (concat j-type "\"delete\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]}}")) (aType-1 (make-construct 'TopicC :start-revision rev-1 :psis (list (make-construct 'PersistentIdC @@ -2066,9 +2064,9 @@ (j-role-3 "{\"type\":[\"rType-1\"],\"topicRef\":[\"player-2\"]}") (rev-1 100) (rev-2 200)) - (let ((j-req-1 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3"]},\"delete\":" j-role-1 "}")) - (j-req-2 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-1 "}")) - (j-req-3 (concatenate 'string j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-2 "}")) + (let ((j-req-1 (concat j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":[[\"aScope-1\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3"]},\"delete\":" j-role-1 "}")) + (j-req-2 (concat j-type "\"parent\":{\"type\":[\"aType-2\"],\"scopes\":[[\"aScope-1\"],[\"aScope-2\"]],\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-1 "}")) + (j-req-3 (concat j-type "\"parent\":{\"type\":[\"aType-1\"],\"scopes\":null,\"roles\":[" j-role-1 "," j-role-2 "," j-role-3 "]},\"delete\":" j-role-2 "}")) (aType-1 (make-construct 'TopicC :start-revision rev-1 :psis (list (make-construct 'PersistentIdC Modified: trunk/src/unit_tests/rdf_exporter_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_exporter_test.lisp (original) +++ trunk/src/unit_tests/rdf_exporter_test.lisp Wed Jan 5 18:37:15 2011 @@ -13,7 +13,8 @@ :xml-importer :datamodel :it.bese.FiveAM - :fixtures) + :fixtures + :base-tools) (:import-from :constants *rdf-ns* *rdfs-ns* @@ -99,7 +100,7 @@ (+ 3 (length item-identifiers))) (string= node-ns *tm2rdf-ns*) (string= node-name "role") - (type-p descr (concatenate 'string *tm2rdf-ns* "types/Role")) + (type-p descr (concat *tm2rdf-ns* "types/Role")) (if player-uri (property-p descr *tm2rdf-ns* "player" :resource player-uri) @@ -227,8 +228,7 @@ (length (loop for ii in item-identifiers when (identifier-p descr ii) collect ii))) - (type-p descr (concatenate 'string *tm2rdf-ns* - "types/Variant")))) + (type-p descr (concat *tm2rdf-ns* "types/Variant")))) return t)) @@ -252,8 +252,7 @@ (length variants))) (string= node-ns *tm2rdf-ns*) (string= node-name "name") - (type-p descr (concatenate 'string *tm2rdf-ns* - "types/Name")) + (type-p descr (concat *tm2rdf-ns* "types/Name")) (property-p descr *tm2rdf-ns* "nametype" :resource name-type) (= (length name-scopes) (length (loop for scope in name-scopes @@ -295,8 +294,7 @@ (length item-identifiers))) (string= node-ns *tm2rdf-ns*) (string= node-name "occurrence") - (type-p descr (concatenate 'string *tm2rdf-ns* - "types/Occurrence")) + (type-p descr (concat *tm2rdf-ns* "types/Occurrence")) (property-p descr *tm2rdf-ns* "occurrencetype" :resource occurrence-type) (= (length occurrence-scopes) @@ -345,15 +343,15 @@ "von Goethe")) (is (name-p me "http://some.where/relationship/firstName" nil (list "http://some.where/name_ii_1") "Johann Wolfgang")) - (let ((born-id (concatenate - 'string "id_" + (let ((born-id (concat + "id_" (write-to-string (elephant::oid (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "28.08.1749")))))) - (died-id (concatenate - 'string "id_" + (died-id (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -383,7 +381,7 @@ erlkoenigs))) (is-true me) (is-true (type-p me "http://some.where/types/Ballad")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) + (is-true (type-p me (concat *tm2rdf-ns* "types/Topic"))) (is-true (literal-p me *sw-arc* "content" "Wer reitet so spät durch Nacht und Wind? ..." :xml-lang "de")) @@ -391,8 +389,8 @@ (list "http://some.where/scope/en") nil "Der Erlkönig")) (let ((dateRange-id - (concatenate - 'string "id_" + (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -419,8 +417,8 @@ "Bedecke deinen Himmel, Zeus, ..." :xml-lang "de")) (let ((dateRange-id - (concatenate - 'string "id_" + (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -441,7 +439,7 @@ zauberlehrlings))) (is-true me) (is-true (type-p me "http://some.where/types/Poem")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) + (is-true (type-p me (concat *tm2rdf-ns* "types/Topic"))) (is-true (identifier-p me "http://some.where/poem/Zauberlehrling" :what "subjectIdentifier")) (is-true (identifier-p @@ -461,8 +459,8 @@ "http://some.where/occurrence_ii_2") "Der Zauberlehrling")) (let ((dateRange-id - (concatenate - 'string "id_" + (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -596,8 +594,8 @@ (test test-born-event "Tests the blank node of the born-event." (with-fixture rdf-exporter-test-db () - (let ((born-id (concatenate - 'string "id_" + (let ((born-id (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -623,8 +621,8 @@ (test test-died-event "Tests the blank node of the born-event." (with-fixture rdf-exporter-test-db () - (let ((born-id (concatenate - 'string "id_" + (let ((born-id (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -650,8 +648,8 @@ (test test-dateRange-zauberlehrling "Tests the node of zauberlehrling's dateRange." (with-fixture rdf-exporter-test-db () - (let ((dr-id (concatenate - 'string "id_" + (let ((dr-id (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -671,8 +669,8 @@ (test test-dateRange-erlkoenig "Tests the node of erlkoenig's dateRange." (with-fixture rdf-exporter-test-db () - (let ((dr-id (concatenate - 'string "id_" + (let ((dr-id (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -692,8 +690,8 @@ (test test-dateRange-prometheus "Tests the node of prometheus' dateRange." (with-fixture rdf-exporter-test-db () - (let ((dr-id (concatenate - 'string "id_" + (let ((dr-id (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -713,8 +711,8 @@ (test test-schiller "Tests the node of schiller." (with-fixture rdf-exporter-test-db () - (let ((schiller-id (concatenate - 'string "id_" + (let ((schiller-id (concat + "id_" (write-to-string (elephant::oid (d:parent @@ -725,7 +723,7 @@ (is (= (length (get-resources-by-id schiller-id)) 1)) (let ((me (elt (get-resources-by-id schiller-id) 0))) (is-true (type-p me "http://some.where/types/Author")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) + (is-true (type-p me (concat *tm2rdf-ns* "types/Topic"))) (is-true (literal-p me *sw-arc* "authorInfo" "http://de.wikipedia.org/wiki/Schiller" :datatype *xml-uri*)) @@ -755,7 +753,7 @@ (poem (get-resources-by-uri "http://some.where/types/Poem")) (ballad (get-resources-by-uri "http://some.where/types/Ballad")) (language (get-resources-by-uri "http://some.where/types/Language")) - (rdf-nil (get-resources-by-uri (concatenate 'string *rdf-ns* "nil")))) + (rdf-nil (get-resources-by-uri (concat *rdf-ns* "nil")))) (is-true authors) (is (= (length authors) 1)) (is (= (length (dom:child-nodes (elt authors 0))) 0)) @@ -842,7 +840,7 @@ (property-p (elt node-3s 0) *rdf-ns* "rest" :resource - (concatenate 'string *rdf-ns* "nil"))))))))))))))) + (concat *rdf-ns* "nil"))))))))))))))) (test test-association @@ -855,21 +853,20 @@ "http://some.where/test-association"))))) (is-true assoc-id) (let ((assocs (get-resources-by-id - (concatenate 'string "id_" (write-to-string assoc-id))))) + (concat "id_" (write-to-string assoc-id))))) (is (= (length assocs))) (let ((me (elt assocs 0))) (is (= (length (dom:child-nodes me)) 7)) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Association"))) + (is-true (type-p me (concat *tm2rdf-ns* "types/Association"))) (is-true (identifier-p me "http://some.where/test-association")) (is-true (property-p me *tm2rdf-ns* "associationtype" - :resource (concatenate - 'string *sw-arc* - "associatedWithEachOther"))) + :resource (concat + *sw-arc* "associatedWithEachOther"))) (is-true (role-p me "http://some.where/roletype/writer" nil :player-uri "http://some.where/author/Goethe")) - (let ((schiller-id (concatenate - 'string "id_" + (let ((schiller-id (concat + "id_" (write-to-string (elephant::oid (d:parent Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Wed Jan 5 18:37:15 2011 @@ -12,6 +12,7 @@ :common-lisp :xml-importer :datamodel + :base-tools :it.bese.FiveAM :fixtures) (:import-from :constants @@ -92,12 +93,12 @@ (test test-get-literals-of-node "Tests the helper function get-literals-of-node." (let ((doc-1 - (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:isi=\"http://isidorus/test#\" " - "rdf:type=\"rdfType\" rdf:ID=\"rdfID\" rdf:nodeID=\"" - "rdfNodeID\" rdf:unknown=\"rdfUnknown\" " - "isi:ID=\"isiID\" isi:arc=\"isiArc\" " - "isi:empty=\"\"/>"))) + (concat "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:isi=\"http://isidorus/test#\" " + "rdf:type=\"rdfType\" rdf:ID=\"rdfID\" rdf:nodeID=\"" + "rdfNodeID\" rdf:unknown=\"rdfUnknown\" " + "isi:ID=\"isiID\" isi:arc=\"isiArc\" " + "isi:empty=\"\"/>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is (= (length (dom:child-nodes dom-1)) 1)) (let ((literals (rdf-importer::get-literals-of-node @@ -108,7 +109,7 @@ (and (string= (getf x :value) "rdfUnknown") (string= (getf x :type) - (concatenate 'string *rdf-ns* "unknown")) + (concat *rdf-ns* "unknown")) (not (getf x :ID)))) literals)) (is-true (find-if #'(lambda(x) @@ -147,7 +148,7 @@ (and (string= (getf x :value) "rdfUnknown") (string= (getf x :type) - (concatenate 'string *rdf-ns* "unknown")) + (concat *rdf-ns* "unknown")) (not (getf x :ID)))) literals)) (is-true (find-if #'(lambda(x) @@ -178,15 +179,15 @@ (test test-parse-node "Tests the parse-node function." (let ((doc-1 - (concatenate 'string "<rdf:UnknownType xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:isi=\"" *rdf2tm-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\" " - "rdf:ID=\"rdfID\" xml:base=\"xmlBase\" " - "arcs:arc=\"arcsArc\">" - "<arcs:rel>" - "<rdf:Description rdf:about=\"element\"/>" - "</arcs:rel>" - "</rdf:UnknownType>"))) + (concat "<rdf:UnknownType xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:isi=\"" *rdf2tm-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "rdf:ID=\"rdfID\" xml:base=\"xmlBase\" " + "arcs:arc=\"arcsArc\">" + "<arcs:rel>" + "<rdf:Description rdf:about=\"element\"/>" + "</arcs:rel>" + "</rdf:UnknownType>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is (length (dom:child-nodes dom-1)) 1) (let ((node (elt (dom:child-nodes dom-1) 0))) @@ -220,14 +221,14 @@ (test test-get-literals-of-property "Tests the function get-literals-or-property." (let ((doc-1 - (concatenate 'string "<prop:property xmlns:prop=\"http://props/\" " - "xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:rdfs=\"" *rdfs-ns* "\" " - "rdf:type=\"rdfType\" rdf:resource=\"rdfResource\" " - "rdf:nodeID=\"rdfNodeID\" " - "prop:prop1=\"http://should/be/a/literal\" " - "prop:prop2=\"prop-2\" " - "prop:prop3=\"\">content-text</prop:property>"))) + (concat "<prop:property xmlns:prop=\"http://props/\" " + "xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:rdfs=\"" *rdfs-ns* "\" " + "rdf:type=\"rdfType\" rdf:resource=\"rdfResource\" " + "rdf:nodeID=\"rdfNodeID\" " + "prop:prop1=\"http://should/be/a/literal\" " + "prop:prop2=\"prop-2\" " + "prop:prop3=\"\">content-text</prop:property>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is-true dom-1) (is (= (length (dom:child-nodes dom-1)) 1)) @@ -258,39 +259,39 @@ (test test-parse-property "Tests the function parse-property." (let ((doc-1 - (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:rdfs=\"" *rdfs-ns* "\" " - "xmlns:prop=\"http://isidorus/props/\">" - "<prop:prop0 rdf:parseType=\"Resource\" />" - "<prop:prop1 rdf:parseType=\"Resource\">" - "<prop:prop1_0 rdf:resource=\"prop21\" />" - "</prop:prop1>" - "<prop:prop2 rdf:parseType=\"Literal\">" - "<content_root>content-text</content_root>" - "</prop:prop2>" - "<prop:prop3 rdf:parseType=\"Collection\" />" - "<prop:prop4 rdf:parseType=\"Collection\">" - "<prop:prop4_0 rdf:resource=\"prop5_1\" />" - "<prop:prop4_1 rdf:nodeID=\"prop5_2\" />" - "<prop:prop4_2/>" - "</prop:prop4>" - "<prop:prop5 />" - "<prop:prop6>prop6</prop:prop6>" - "<prop:prop7 rdf:nodeID=\"prop7\"/>" - "<prop:prop8 rdf:resource=\"prop8\" />" - "<prop:prop9 rdf:type=\"typeProp9\"> </prop:prop9>" - "<prop:prop10 rdf:datatype=\"datatypeProp10\" />" - "<prop:prop11 rdf:ID=\"IDProp11\"> </prop:prop11>" - "<prop:prop12 rdf:ID=\"IDprop12\" rdf:nodeID=\"prop12\">" - " </prop:prop12>" - "<prop:prop13 />" - "<prop:prop14>prop14</prop:prop14>" - "<prop:prop15 rdf:nodeID=\"prop15\"/>" - "<prop:prop16 rdf:resource=\"prop16\" />" - "<prop:prop17 rdf:type=\"typeProp17\"> </prop:prop17>" - "<prop:prop18 rdf:ID=\"IDprop18\" rdf:nodeID=\"prop18\">" - " </prop:prop18>" - "</rdf:Description>"))) + (concat "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:rdfs=\"" *rdfs-ns* "\" " + "xmlns:prop=\"http://isidorus/props/\">" + "<prop:prop0 rdf:parseType=\"Resource\" />" + "<prop:prop1 rdf:parseType=\"Resource\">" + "<prop:prop1_0 rdf:resource=\"prop21\" />" + "</prop:prop1>" + "<prop:prop2 rdf:parseType=\"Literal\">" + "<content_root>content-text</content_root>" + "</prop:prop2>" + "<prop:prop3 rdf:parseType=\"Collection\" />" + "<prop:prop4 rdf:parseType=\"Collection\">" + "<prop:prop4_0 rdf:resource=\"prop5_1\" />" + "<prop:prop4_1 rdf:nodeID=\"prop5_2\" />" + "<prop:prop4_2/>" + "</prop:prop4>" + "<prop:prop5 />" + "<prop:prop6>prop6</prop:prop6>" + "<prop:prop7 rdf:nodeID=\"prop7\"/>" + "<prop:prop8 rdf:resource=\"prop8\" />" + "<prop:prop9 rdf:type=\"typeProp9\"> </prop:prop9>" + "<prop:prop10 rdf:datatype=\"datatypeProp10\" />" + "<prop:prop11 rdf:ID=\"IDProp11\"> </prop:prop11>" + "<prop:prop12 rdf:ID=\"IDprop12\" rdf:nodeID=\"prop12\">" + " </prop:prop12>" + "<prop:prop13 />" + "<prop:prop14>prop14</prop:prop14>" + "<prop:prop15 rdf:nodeID=\"prop15\"/>" + "<prop:prop16 rdf:resource=\"prop16\" />" + "<prop:prop17 rdf:type=\"typeProp17\"> </prop:prop17>" + "<prop:prop18 rdf:ID=\"IDprop18\" rdf:nodeID=\"prop18\">" + " </prop:prop18>" + "</rdf:Description>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is-true dom-1) (is (= (length (dom:child-nodes dom-1)) 1)) @@ -378,40 +379,40 @@ get-node-rerfs, absolute-uri-p, absolutize-value and absolutize-id." (let ((tm-id "http://test-tm") (doc-1 - (concatenate 'string "<rdf:anyType xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:isi=\"" *rdf2tm-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\" " - "xml:base=\"xml-base/first\" " - "rdf:about=\"resource\" rdf:type=\"attr-type\">" - "<rdf:type rdf:ID=\"rdfID\" " - "rdf:resource=\"content-type-1\"/>" - "<rdf:type />" - "<rdf:type arcs:arc=\"literalArc\"/>" - "<rdf:type rdf:parseType=\"Collection\" " - " xml:base=\"http://xml-base/absolute/\">" - "" - "<rdf:Description rdf:about=\"c-about-type\"/>" - "<rdf:Description rdf:ID=\"c-id-type\"/>" - "<rdf:Description rdf:nodeID=\"c-nodeID-type\"/>" - "<rdf:Description/>" - "</rdf:type>" - "<rdf:type rdf:ID=\"rdfID2\">" - "<rdf:Description rdf:about=\"c-about-type-2\"/>" - "</rdf:type>" - "<rdf:type>" - "<rdf:Description rdf:nodeID=\"c-nodeID-type-2\"/>" - "</rdf:type>" - "<rdf:type xml:base=\"http://new-base/\">" - "<rdf:Description rdf:ID=\"c-ID-type-2\"/>" - "</rdf:type>" - "<rdf:type rdf:ID=\"rdfID3\">" - "<rdf:Description/>" - "</rdf:type>" - "<arcs:arc rdf:resource=\"anyArc\"/>" - "<rdf:arc>" - "<rdf:Description rdf:about=\"anyResource\"/>" - "</rdf:arc>" - "</rdf:anyType>"))) + (concat "<rdf:anyType xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:isi=\"" *rdf2tm-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "xml:base=\"xml-base/first\" " + "rdf:about=\"resource\" rdf:type=\"attr-type\">" + "<rdf:type rdf:ID=\"rdfID\" " + "rdf:resource=\"content-type-1\"/>" + "<rdf:type />" + "<rdf:type arcs:arc=\"literalArc\"/>" + "<rdf:type rdf:parseType=\"Collection\" " + " xml:base=\"http://xml-base/absolute/\">" + "" + "<rdf:Description rdf:about=\"c-about-type\"/>" + "<rdf:Description rdf:ID=\"c-id-type\"/>" + "<rdf:Description rdf:nodeID=\"c-nodeID-type\"/>" + "<rdf:Description/>" + "</rdf:type>" + "<rdf:type rdf:ID=\"rdfID2\">" + "<rdf:Description rdf:about=\"c-about-type-2\"/>" + "</rdf:type>" + "<rdf:type>" + "<rdf:Description rdf:nodeID=\"c-nodeID-type-2\"/>" + "</rdf:type>" + "<rdf:type xml:base=\"http://new-base/\">" + "<rdf:Description rdf:ID=\"c-ID-type-2\"/>" + "</rdf:type>" + "<rdf:type rdf:ID=\"rdfID3\">" + "<rdf:Description/>" + "</rdf:type>" + "<arcs:arc rdf:resource=\"anyArc\"/>" + "<rdf:arc>" + "<rdf:Description rdf:about=\"anyResource\"/>" + "</rdf:arc>" + "</rdf:anyType>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is-true dom-1) (is (= (length (dom:child-nodes dom-1)) 1)) @@ -439,23 +440,19 @@ (is-true (find-if #'(lambda(x) (and (string= (getf x :topicid) - (concatenate - 'string *rdf-ns* "anyType")) + (concat *rdf-ns* "anyType")) (string= (getf x :topicid) - (concatenate - 'string *rdf-ns* "anyType")) + (concat *rdf-ns* "anyType")) (not (getf x :ID)))) types)) (is-true (find-if #'(lambda(x) (and (string= (getf x :topicid) - (concatenate - 'string tm-id + (concat tm-id "/xml-base/first/attr-type")) (string= (getf x :psi) - (concatenate - 'string tm-id - "/xml-base/first/attr-type")) + (concat tm-id + "/xml-base/first/attr-type")) (not (getf x :ID)))) types)) (is-true (find-if @@ -470,12 +467,10 @@ (is-true (find-if #'(lambda(x) (and (string= (getf x :topicid) - (concatenate - 'string tm-id + (concat tm-id "/xml-base/first/c-about-type-2")) (string= (getf x :psi) - (concatenate - 'string tm-id + (concat tm-id "/xml-base/first/c-about-type-2")) (string= (getf x :ID) "http://test-tm/xml-base/first#rdfID2"))) @@ -508,26 +503,26 @@ (test test-get-literals-of-content (let ((doc-1 - (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:rdfs=\"" *rdfs-ns* "\" " - "xmlns:prop=\"http://isidorus/props/\" " - "xml:base=\"base/first\" xml:lang=\"de\" >" - "<prop:lit0>text0</prop:lit0>" - "<prop:lit1 rdf:parseType=\"Literal\">text1</prop:lit1>" - "<prop:lit2 xml:base=\"http://base/absolute\" " - "rdf:datatype=\"dType1\">text2</prop:lit2>" - "<prop:arc rdf:parseType=\"Collection\"/>" - "<prop:lit3 xml:lang=\"en\" rdf:datatype=\"dType2\">" - "<![CDATA[text3]]></prop:lit3>" - "<prop:lit4 rdf:datatype=\"dType2\"><root><child/></root>" - " </prop:lit4>" - "<prop:lit5 rdf:ID=\"rdfID\" " - "rdf:parseType=\"Literal\"><root><child>" - "childText5</child> </root></prop:lit5>" - "<prop:lit6 xml:lang=\"\" rdf:parseType=\"Literal\">" - " <![CDATA[text6]]> abc " - "</prop:lit6>" - "</rdf:Description>"))) + (concat "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:rdfs=\"" *rdfs-ns* "\" " + "xmlns:prop=\"http://isidorus/props/\" " + "xml:base=\"base/first\" xml:lang=\"de\" >" + "<prop:lit0>text0</prop:lit0>" + "<prop:lit1 rdf:parseType=\"Literal\">text1</prop:lit1>" + "<prop:lit2 xml:base=\"http://base/absolute\" " + "rdf:datatype=\"dType1\">text2</prop:lit2>" + "<prop:arc rdf:parseType=\"Collection\"/>" + "<prop:lit3 xml:lang=\"en\" rdf:datatype=\"dType2\">" + "<![CDATA[text3]]></prop:lit3>" + "<prop:lit4 rdf:datatype=\"dType2\"><root><child/></root>" + " </prop:lit4>" + "<prop:lit5 rdf:ID=\"rdfID\" " + "rdf:parseType=\"Literal\"><root><child>" + "childText5</child> </root></prop:lit5>" + "<prop:lit6 xml:lang=\"\" rdf:parseType=\"Literal\">" + " <![CDATA[text6]]> abc " + "</prop:lit6>" + "</rdf:Description>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) (tm-id "http://test-tm")) (is-true dom-1) @@ -612,41 +607,41 @@ (test test-get-super-classes-of-node-content (let ((doc-1 - (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:isi=\"" *rdf2tm-ns* "\" " - "xmlns:rdfs=\"" *rdfs-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\" " - "xml:base=\"xml-base/first\" " - "rdf:about=\"resource\" rdf:type=\"attr-type\">" - "<rdfs:subClassOf rdf:ID=\"rdfID\" " - "rdf:resource=\"content-type-1\"/>" - "<rdfs:subClassOf />" - "<rdfs:subClassOf arcs:arc=\"literalArc\"/>" - "<rdfs:subClassOf rdf:parseType=\"Collection\" " - " xml:base=\"http://xml-base/absolute/\">" - "" - "<rdf:Description rdf:about=\"c-about-type\"/>" - "<rdf:Description rdf:ID=\"c-id-type\"/>" - "<rdf:Description rdf:nodeID=\"c-nodeID-type\"/>" - "<rdf:Description/>" - "</rdfs:subClassOf>" - "<rdfs:subClassOf rdf:ID=\"rdfID2\">" - "<rdf:Description rdf:about=\"c-about-type-2\"/>" - "</rdfs:subClassOf>" - "<rdfs:subClassOf>" - "<rdf:Description rdf:nodeID=\"c-nodeID-type-2\"/>" - "</rdfs:subClassOf>" - "<rdfs:subClassOf xml:base=\"http://new-base/\">" - "<rdf:Description rdf:ID=\"c-ID-type-2\"/>" - "</rdfs:subClassOf>" - "<rdfs:subClassOf rdf:ID=\"rdfID3\">" - "<rdf:Description/>" - "</rdfs:subClassOf>" - "<arcs:arc rdf:resource=\"anyArc\"/>" - "<rdfs:arc>" - "<rdf:Description rdf:about=\"anyResource\"/>" - "</rdfs:arc>" - "</rdf:Description>"))) + (concat "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:isi=\"" *rdf2tm-ns* "\" " + "xmlns:rdfs=\"" *rdfs-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "xml:base=\"xml-base/first\" " + "rdf:about=\"resource\" rdf:type=\"attr-type\">" + "<rdfs:subClassOf rdf:ID=\"rdfID\" " + "rdf:resource=\"content-type-1\"/>" + "<rdfs:subClassOf />" + "<rdfs:subClassOf arcs:arc=\"literalArc\"/>" + "<rdfs:subClassOf rdf:parseType=\"Collection\" " + " xml:base=\"http://xml-base/absolute/\">" + "" + "<rdf:Description rdf:about=\"c-about-type\"/>" + "<rdf:Description rdf:ID=\"c-id-type\"/>" + "<rdf:Description rdf:nodeID=\"c-nodeID-type\"/>" + "<rdf:Description/>" + "</rdfs:subClassOf>" + "<rdfs:subClassOf rdf:ID=\"rdfID2\">" + "<rdf:Description rdf:about=\"c-about-type-2\"/>" + "</rdfs:subClassOf>" + "<rdfs:subClassOf>" + "<rdf:Description rdf:nodeID=\"c-nodeID-type-2\"/>" + "</rdfs:subClassOf>" + "<rdfs:subClassOf xml:base=\"http://new-base/\">" + "<rdf:Description rdf:ID=\"c-ID-type-2\"/>" + "</rdfs:subClassOf>" + "<rdfs:subClassOf rdf:ID=\"rdfID3\">" + "<rdf:Description/>" + "</rdfs:subClassOf>" + "<arcs:arc rdf:resource=\"anyArc\"/>" + "<rdfs:arc>" + "<rdf:Description rdf:about=\"anyResource\"/>" + "</rdfs:arc>" + "</rdf:Description>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is-true dom-1) (is (= (length (dom:child-nodes dom-1)))) @@ -679,15 +674,13 @@ (and (string= (getf x :topicid) - (concatenate 'string tm-id xml-base - "/xml-base/first/c-about-type-2")) + (concat tm-id xml-base "/xml-base/first/c-about-type-2")) (string= (getf x :psi) - (concatenate 'string tm-id xml-base - "/xml-base/first/c-about-type-2")) + (concat tm-id xml-base "/xml-base/first/c-about-type-2")) (string= (getf x :ID) - (concatenate 'string tm-id xml-base - "/xml-base/first#rdfID2")))) + (concat tm-id xml-base + "/xml-base/first#rdfID2")))) super-classes)) (is-true (find-if #'(lambda(x) @@ -723,43 +716,43 @@ (test test-get-associations-of-node-content (let ((doc-1 - (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:isi=\"" *rdf2tm-ns* "\" " - "xmlns:rdfs=\"" *rdfs-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\" " - "xml:base=\"http://xml-base/first\" " - "rdf:about=\"resource\" rdf:type=\"attr-type\">" - "<rdf:type rdf:resource=\"anyType\" />" - "<rdf:type> </rdf:type>" - "<rdfs:subClassOf rdf:nodeID=\"anyClass\" />" - "<rdfs:subClassOf> </rdfs:subClassOf>" - "<rdf:unknown rdf:resource=\"assoc-1\"/>" - "<rdfs:unknown rdf:type=\"assoc-2-type\">" - " </rdfs:unknown>" - "<arcs:arc1 rdf:ID=\"rdfID-1\" " - "rdf:nodeID=\"arc1-nodeID\"/>" - "<arcs:arc2 rdf:parseType=\"Collection\">" - "<rdf:Description rdf:about=\"col\" />" - "</arcs:arc2>" - "<arcs:arc3 rdf:parseType=\"Resource\" " - "rdf:ID=\"rdfID-2\" />" - "<arcs:lit rdf:parseType=\"Literal\" />" - "<arcs:arc4 arcs:arc5=\"text-arc5\" />" - "<arcs:arc6 rdf:ID=\"rdfID-3\">" - "<rdf:Description rdf:about=\"con-1\" />" - "</arcs:arc6>" - "<arcs:arc7>" - "<rdf:Description rdf:nodeID=\"con-2\" />" - "</arcs:arc7>" - "<arcs:arc8>" - "<rdf:Description rdf:ID=\"rdfID-4\" />" - "</arcs:arc8>" - "<arcs:arc9 rdf:ID=\"rdfID-5\" xml:base=\"add\">" - "<rdf:Description />" - "</arcs:arc9>" - "<rdfs:type rdf:resource=\"assoc-11\"> </rdfs:type>" - "<rdf:subClassOf rdf:nodeID=\"assoc-12\" />" - "</rdf:Description>"))) + (concat "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:isi=\"" *rdf2tm-ns* "\" " + "xmlns:rdfs=\"" *rdfs-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "xml:base=\"http://xml-base/first\" " + "rdf:about=\"resource\" rdf:type=\"attr-type\">" + "<rdf:type rdf:resource=\"anyType\" />" + "<rdf:type> </rdf:type>" + "<rdfs:subClassOf rdf:nodeID=\"anyClass\" />" + "<rdfs:subClassOf> </rdfs:subClassOf>" + "<rdf:unknown rdf:resource=\"assoc-1\"/>" + "<rdfs:unknown rdf:type=\"assoc-2-type\">" + " </rdfs:unknown>" + "<arcs:arc1 rdf:ID=\"rdfID-1\" " + "rdf:nodeID=\"arc1-nodeID\"/>" + "<arcs:arc2 rdf:parseType=\"Collection\">" + "<rdf:Description rdf:about=\"col\" />" + "</arcs:arc2>" + "<arcs:arc3 rdf:parseType=\"Resource\" " + "rdf:ID=\"rdfID-2\" />" + "<arcs:lit rdf:parseType=\"Literal\" />" + "<arcs:arc4 arcs:arc5=\"text-arc5\" />" + "<arcs:arc6 rdf:ID=\"rdfID-3\">" + "<rdf:Description rdf:about=\"con-1\" />" + "</arcs:arc6>" + "<arcs:arc7>" + "<rdf:Description rdf:nodeID=\"con-2\" />" + "</arcs:arc7>" + "<arcs:arc8>" + "<rdf:Description rdf:ID=\"rdfID-4\" />" + "</arcs:arc8>" + "<arcs:arc9 rdf:ID=\"rdfID-5\" xml:base=\"add\">" + "<rdf:Description />" + "</arcs:arc9>" + "<rdfs:type rdf:resource=\"assoc-11\"> </rdfs:type>" + "<rdf:subClassOf rdf:nodeID=\"assoc-12\" />" + "</rdf:Description>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) (tm-id "http://test-tm")) (is-true dom-1) @@ -773,7 +766,7 @@ (is-true (find-if #'(lambda(x) (and (string= (getf x :type) - (concatenate 'string *rdf-ns* "unknown")) + (concat *rdf-ns* "unknown")) (string= (getf x :topicid) "http://xml-base/first/assoc-1") (string= (getf x :psi) @@ -853,7 +846,7 @@ (is-true (find-if #'(lambda(x) (and (string= (getf x :type) - (concatenate 'string *rdfs-ns* "type")) + (concat *rdfs-ns* "type")) (not (getf x :ID)) (string= (getf x :psi) "http://xml-base/first/assoc-11") @@ -863,8 +856,7 @@ (is-true (find-if #'(lambda(x) (and (string= (getf x :type) - (concatenate 'string *rdf-ns* - "subClassOf")) + (concat *rdf-ns* "subClassOf")) (not (getf x :ID)) (not (getf x :psi)) (string= (getf x :topicid) "assoc-12"))) @@ -873,24 +865,24 @@ (test test-parse-properties-of-node (let ((doc-1 - (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\" " - "xml:base=\"http://xml-base/first\" " - "rdf:about=\"resource\" rdf:type=\"attr-type\" " - "rdf:li=\"li-attr\">" - "<rdf:li rdf:resource=\"anyType\" />" - "<rdf:li> text-1 </rdf:li>" - "<rdf:li rdf:nodeID=\"anyClass\" />" - "<rdf:li> </rdf:li>" - "<rdf:li rdf:resource=\"assoc-1\"/>" - "<rdf:li rdf:type=\"assoc-2-type\">" - " </rdf:li>" - "<rdf:li rdf:parseType=\"Literal\" > text-3</rdf:li>" - "<rdf:_123 arcs:arc5=\"text-arc5\"/>" - "<rdf:arc6 rdf:ID=\"rdfID-3\"> text-4 </rdf:arc6>" - "<rdf:arcs rdf:ID=\"rdfID-4\" xml:lang=\" \">" - "text-5</rdf:arcs>" - "</rdf:Description>"))) + (concat "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "xml:base=\"http://xml-base/first\" " + "rdf:about=\"resource\" rdf:type=\"attr-type\" " + "rdf:li=\"li-attr\">" + "<rdf:li rdf:resource=\"anyType\" />" + "<rdf:li> text-1 </rdf:li>" + "<rdf:li rdf:nodeID=\"anyClass\" />" + "<rdf:li> </rdf:li>" + "<rdf:li rdf:resource=\"assoc-1\"/>" + "<rdf:li rdf:type=\"assoc-2-type\">" + " </rdf:li>" + "<rdf:li rdf:parseType=\"Literal\" > text-3</rdf:li>" + "<rdf:_123 arcs:arc5=\"text-arc5\"/>" + "<rdf:arc6 rdf:ID=\"rdfID-3\"> text-4 </rdf:arc6>" + "<rdf:arcs rdf:ID=\"rdfID-4\" xml:lang=\" \">" + "text-5</rdf:arcs>" + "</rdf:Description>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) (tm-id "http://test-tm")) (setf rdf-importer::*_n-map* nil) @@ -906,9 +898,8 @@ (is-true (find-if #'(lambda(x) (string= (getf x :name) - (concatenate - 'string *rdf-ns* "_" - (write-to-string (+ 1 iter))))) + (concat *rdf-ns* "_" + (write-to-string (+ 1 iter))))) (getf (first rdf-importer::*_n-map*) :props)))) (let ((assocs (rdf-importer::get-associations-of-node-content node tm-id nil)) @@ -921,7 +912,7 @@ (is (= (length attr-literals) 1)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) - (concatenate 'string *rdf-ns* "_1")) + (concat *rdf-ns* "_1")) (not (getf x :lang)) (string= (getf x :value) "li-attr") (not (getf x :lang)) @@ -933,7 +924,7 @@ (string= (getf x :psi) "http://xml-base/first/anyType") (string= (getf x :type) - (concatenate 'string *rdf-ns* "_2")) + (concat *rdf-ns* "_2")) (not (getf x :ID)))) assocs)) (is-true (find-if #'(lambda(x) @@ -941,20 +932,20 @@ (string= (getf x :lang) "de") (string= (getf x :datatype) *xml-string*) (string= (getf x :type) - (concatenate 'string *rdf-ns* "_3")) + (concat *rdf-ns* "_3")) (not (getf x :ID)))) content-literals)) (is-true (find-if #'(lambda(x) (and (string= (getf x :topicid) "anyClass") (not (getf x :psi)) (string= (getf x :type) - (concatenate 'string *rdf-ns* "_4")) + (concat *rdf-ns* "_4")) (not (getf x :ID)))) assocs)) (is-true (find-if #'(lambda(x) (and (string= (getf x :value) " ") (string= (getf x :type) - (concatenate 'string *rdf-ns* "_5")) + (concat *rdf-ns* "_5")) (string= (getf x :datatype) *xml-string*) (string= (getf x :lang) "de") (not (getf x :ID)))) @@ -965,14 +956,14 @@ (string= (getf x :psi) "http://xml-base/first/assoc-1") (string= (getf x :type) - (concatenate 'string *rdf-ns* "_6")) + (concat *rdf-ns* "_6")) (not (getf x :ID)))) assocs)) (is-true (find-if #'(lambda(x) (and (> (length (getf x :topicid)) 0) (not (getf x :psi)) (string= (getf x :type) - (concatenate 'string *rdf-ns* "_7")) + (concat *rdf-ns* "_7")) (not (getf x :ID)))) assocs)) (is-true (find-if #'(lambda(x) @@ -980,7 +971,7 @@ (string= (getf x :lang) "de") (string= (getf x :datatype) *xml-string*) (string= (getf x :type) - (concatenate 'string *rdf-ns* "_8")) + (concat *rdf-ns* "_8")) (not (getf x :ID)))) content-literals)) (is-true (find-if #'(lambda(x) @@ -989,7 +980,7 @@ (string= (getf x :datatype) *xml-string*) (string= (getf x :type) - (concatenate 'string *rdf-ns* "arc6")) + (concat *rdf-ns* "arc6")) (string= (getf x :ID) "http://xml-base/first#rdfID-3"))) @@ -1000,7 +991,7 @@ (string= (getf x :datatype) *xml-string*) (string= (getf x :type) - (concatenate 'string *rdf-ns* "arcs")) + (concat *rdf-ns* "arcs")) (string= (getf x :ID) "http://xml-base/first#rdfID-4"))) @@ -1017,32 +1008,32 @@ (revision-3 300) (document-id "doc-id") (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\" " - "xmlns:rdfs=\"" *rdfs-ns* "\">" - "<rdf:Description rdf:about=\"first-node\">" - "<rdf:type rdf:resource=\"first-type\" />" - "</rdf:Description>" - "<rdf:Description rdf:type=\"second-type\" " - "rdf:nodeID=\"second-node\">" - "<rdfs:subClassOf>" - "<rdf:Description rdf:ID=\"third-node\" />" - "</rdfs:subClassOf>" - "</rdf:Description>" - "<rdf:Description arcs:arc1=\"arc-1\">" - "<arcs:arc2 rdf:datatype=\"dt\">arc-2</arcs:arc2>" - "</rdf:Description>" - "<rdf:Description rdf:about=\"fourth-node\">" - "<arcs:arc3 rdf:parseType=\"Literal\"><root>" - "<content type=\"anyContent\">content</content>" - "</root></arcs:arc3>" - "</rdf:Description>" - "<rdf:Description rdf:ID=\"fifth-node\">" - "<arcs:arc4 rdf:parseType=\"Resource\">" - "<arcs:arc5 rdf:resource=\"arc-5\" />" - "</arcs:arc4>" - "</rdf:Description>" - "</rdf:RDF>"))) + (concat "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "xmlns:rdfs=\"" *rdfs-ns* "\">" + "<rdf:Description rdf:about=\"first-node\">" + "<rdf:type rdf:resource=\"first-type\" />" + "</rdf:Description>" + "<rdf:Description rdf:type=\"second-type\" " + "rdf:nodeID=\"second-node\">" + "<rdfs:subClassOf>" + "<rdf:Description rdf:ID=\"third-node\" />" + "</rdfs:subClassOf>" + "</rdf:Description>" + "<rdf:Description arcs:arc1=\"arc-1\">" + "<arcs:arc2 rdf:datatype=\"dt\">arc-2</arcs:arc2>" + "</rdf:Description>" + "<rdf:Description rdf:about=\"fourth-node\">" + "<arcs:arc3 rdf:parseType=\"Literal\"><root>" + "<content type=\"anyContent\">content</content>" + "</root></arcs:arc3>" + "</rdf:Description>" + "<rdf:Description rdf:ID=\"fifth-node\">" + "<arcs:arc4 rdf:parseType=\"Resource\">" + "<arcs:arc5 rdf:resource=\"arc-5\" />" + "</arcs:arc4>" + "</rdf:Description>" + "</rdf:RDF>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is-true dom-1) (is (= (length (dom:child-nodes dom-1)) 1)) @@ -1238,340 +1229,337 @@ (revision-1 100) (document-id "doc-id") (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\">" - " <rdf:Description rdf:about=\"first-node\">" - " <rdf:type rdf:nodeID=\"second-node\"/>" - " <arcs:arc1 rdf:resource=\"third-node\"/>" - " <arcs:arc2 rdf:datatype=\"long\">123</arcs:arc2>" - " <arcs:arc3>" - " <rdf:Description>" - " <arcs:arc4 rdf:parseType=\"Collection\">" - " <rdf:Description rdf:about=\"item-1\"/>" - " <rdf:Description rdf:about=\"item-2\">" - " <arcs:arc5 rdf:parseType=\"Resource\">" - " <arcs:arc6 rdf:resource=\"fourth-node\"/>" - " <arcs:arc7>" - " <rdf:Description rdf:about=\"fifth-node\"/>" - " </arcs:arc7>" - " <arcs:arc8 rdf:parseType=\"Collection\" />" - " </arcs:arc5>" - " </rdf:Description>" - " </arcs:arc4>" - " </rdf:Description>" - " </arcs:arc3>" - " </rdf:Description>" - " <rdf:Description rdf:nodeID=\"second-node\" />" - "</rdf:RDF>"))) - (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) - (is-true dom-1) - (is (= (length (dom:child-nodes dom-1)) 1)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) - (is (= (length (rdf-importer::child-nodes-or-text rdf-node - :trim t)) - 2)) - (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id - :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 40)) - (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 12)) - (setf rdf-importer::*current-xtm* document-id) - (is (= (length - (intersection - (map 'list #'d:instance-of - (elephant:get-instances-by-class 'd:AssociationC)) - (list - (d:get-item-by-id (concatenate - 'string - constants::*rdf-nil*) - :xtm-id rdf-importer::*rdf-core-xtm*) - (d:get-item-by-psi constants::*type-instance-psi*) - (dotimes (iter 9) - (let ((pos (+ iter 1)) - (topics nil)) - (when (/= pos 2) - (push (get-item-by-id - (concatenate - 'string "http://test/arcs/arc" - (write-to-string pos))) topics)) - topics))))))) - (let ((first-node (get-item-by-id "http://test-tm/first-node")) - (second-node (get-item-by-id "second-node")) - (third-node (get-item-by-id "http://test-tm/third-node")) - (fourth-node (get-item-by-id "http://test-tm/fourth-node")) - (fifth-node (get-item-by-id "http://test-tm/fifth-node")) - (item-1 (get-item-by-id "http://test-tm/item-1")) - (item-2 (get-item-by-id "http://test-tm/item-2")) - (arc1 (get-item-by-id "http://test/arcs/arc1")) - (arc2 (get-item-by-id "http://test/arcs/arc2")) - (arc3 (get-item-by-id "http://test/arcs/arc3")) - (arc4 (get-item-by-id "http://test/arcs/arc4")) - (arc5 (get-item-by-id "http://test/arcs/arc5")) - (arc6 (get-item-by-id "http://test/arcs/arc6")) - (arc7 (get-item-by-id "http://test/arcs/arc7")) - (arc8 (get-item-by-id "http://test/arcs/arc8")) - (instance (d:get-item-by-psi constants::*instance-psi*)) - (type (d:get-item-by-psi constants::*type-psi*)) - (type-instance (d:get-item-by-psi - constants:*type-instance-psi*)) - (subject (d:get-item-by-psi constants::*rdf2tm-subject*)) - (object (d:get-item-by-psi constants::*rdf2tm-object*)) - (rdf-first (d:get-item-by-psi constants:*rdf-first*)) - (rdf-rest (d:get-item-by-psi constants:*rdf-rest*)) - (rdf-nil (d:get-item-by-psi constants:*rdf-nil*))) - (is (= (length (d:psis first-node)) 1)) - (is (string= (d:uri (first (d:psis first-node))) - "http://test-tm/first-node")) - (is (= (length (d:psis second-node)) 0)) - (is (= (length (d:psis third-node)) 1)) - (is (string= (d:uri (first (d:psis third-node))) - "http://test-tm/third-node")) - (is (= (length (d:psis fourth-node)) 1)) - (is (string= (d:uri (first (d:psis fourth-node))) - "http://test-tm/fourth-node")) - (is (= (length (d:psis fifth-node)) 1)) - (is (string= (d:uri (first (d:psis fifth-node))) - "http://test-tm/fifth-node")) - (is (= (length (d:psis item-1)) 1)) - (is (string= (d:uri (first (d:psis item-1))) - "http://test-tm/item-1")) - (is (= (length (d:psis item-2)) 1)) - (is (string= (d:uri (first (d:psis item-2))) - "http://test-tm/item-2")) - (is (= (length (d:psis arc1)) 1)) - (is (string= (d:uri (first (d:psis arc1))) - "http://test/arcs/arc1")) - (is (= (length (d:psis arc2)) 1)) - (is (string= (d:uri (first (d:psis arc2))) - "http://test/arcs/arc2")) - (is (= (length (d:psis arc3)) 1)) - (is (string= (d:uri (first (d:psis arc3))) - "http://test/arcs/arc3")) - (is (= (length (d:psis arc4)) 1)) - (is (string= (d:uri (first (d:psis arc4))) - "http://test/arcs/arc4")) - (is (= (length (d:psis arc5)) 1)) - (is (string= (d:uri (first (d:psis arc5))) - "http://test/arcs/arc5")) - (is (= (length (d:psis arc6)) 1)) - (is (string= (d:uri (first (d:psis arc6))) - "http://test/arcs/arc6")) - (is (= (length (d:psis arc7)) 1)) - (is (string= (d:uri (first (d:psis arc7))) - "http://test/arcs/arc7")) - (is (= (length (d:psis arc8)) 1)) - (is (string= (d:uri (first (d:psis arc8))) - "http://test/arcs/arc8")) - (is (= (length (d:psis rdf-first)) 1)) - (is (string= (d:uri (first (d:psis rdf-first))) - constants:*rdf-first*)) - (is (= (length (d:psis rdf-rest)) 1)) - (is (string= (d:uri (first (d:psis rdf-rest))) - constants:*rdf-rest*)) - (is (= (length (d:psis rdf-nil)) 1)) - (is (string= (d:uri (first (d:psis rdf-nil))) - constants:*rdf-nil*)) - (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) - 1)) - (is (string= (d:charvalue (first (elephant:get-instances-by-class - 'd:OccurrenceC))) - "123")) - (is (string= (d:datatype (first (elephant:get-instances-by-class - 'd:OccurrenceC))) - "http://test-tm/long")) - (is (= (length (d:occurrences first-node)) 1)) - (is (= (length (d:player-in-roles first-node)) 3)) - (is (= (count-if + (concat "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\">" + " <rdf:Description rdf:about=\"first-node\">" + " <rdf:type rdf:nodeID=\"second-node\"/>" + " <arcs:arc1 rdf:resource=\"third-node\"/>" + " <arcs:arc2 rdf:datatype=\"long\">123</arcs:arc2>" + " <arcs:arc3>" + " <rdf:Description>" + " <arcs:arc4 rdf:parseType=\"Collection\">" + " <rdf:Description rdf:about=\"item-1\"/>" + " <rdf:Description rdf:about=\"item-2\">" + " <arcs:arc5 rdf:parseType=\"Resource\">" + " <arcs:arc6 rdf:resource=\"fourth-node\"/>" + " <arcs:arc7>" + " <rdf:Description rdf:about=\"fifth-node\"/>" + " </arcs:arc7>" + " <arcs:arc8 rdf:parseType=\"Collection\" />" + " </arcs:arc5>" + " </rdf:Description>" + " </arcs:arc4>" + " </rdf:Description>" + " </arcs:arc3>" + " </rdf:Description>" + " <rdf:Description rdf:nodeID=\"second-node\" />" + "</rdf:RDF>"))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)) 1)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) + (is (= (length (rdf-importer::child-nodes-or-text rdf-node + :trim t)) + 2)) + (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id + :document-id document-id) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 40)) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 12)) + (setf rdf-importer::*current-xtm* document-id) + (is (= (length + (intersection + (map 'list #'d:instance-of + (elephant:get-instances-by-class 'd:AssociationC)) + (list + (d:get-item-by-id (concat constants::*rdf-nil*) + :xtm-id rdf-importer::*rdf-core-xtm*) + (d:get-item-by-psi constants::*type-instance-psi*) + (dotimes (iter 9) + (let ((pos (+ iter 1)) + (topics nil)) + (when (/= pos 2) + (push (get-item-by-id + (concat "http://test/arcs/arc" + (write-to-string pos))) topics)) + topics))))))) + (let ((first-node (get-item-by-id "http://test-tm/first-node")) + (second-node (get-item-by-id "second-node")) + (third-node (get-item-by-id "http://test-tm/third-node")) + (fourth-node (get-item-by-id "http://test-tm/fourth-node")) + (fifth-node (get-item-by-id "http://test-tm/fifth-node")) + (item-1 (get-item-by-id "http://test-tm/item-1")) + (item-2 (get-item-by-id "http://test-tm/item-2")) + (arc1 (get-item-by-id "http://test/arcs/arc1")) + (arc2 (get-item-by-id "http://test/arcs/arc2")) + (arc3 (get-item-by-id "http://test/arcs/arc3")) + (arc4 (get-item-by-id "http://test/arcs/arc4")) + (arc5 (get-item-by-id "http://test/arcs/arc5")) + (arc6 (get-item-by-id "http://test/arcs/arc6")) + (arc7 (get-item-by-id "http://test/arcs/arc7")) + (arc8 (get-item-by-id "http://test/arcs/arc8")) + (instance (d:get-item-by-psi constants::*instance-psi*)) + (type (d:get-item-by-psi constants::*type-psi*)) + (type-instance (d:get-item-by-psi + constants:*type-instance-psi*)) + (subject (d:get-item-by-psi constants::*rdf2tm-subject*)) + (object (d:get-item-by-psi constants::*rdf2tm-object*)) + (rdf-first (d:get-item-by-psi constants:*rdf-first*)) + (rdf-rest (d:get-item-by-psi constants:*rdf-rest*)) + (rdf-nil (d:get-item-by-psi constants:*rdf-nil*))) + (is (= (length (d:psis first-node)) 1)) + (is (string= (d:uri (first (d:psis first-node))) + "http://test-tm/first-node")) + (is (= (length (d:psis second-node)) 0)) + (is (= (length (d:psis third-node)) 1)) + (is (string= (d:uri (first (d:psis third-node))) + "http://test-tm/third-node")) + (is (= (length (d:psis fourth-node)) 1)) + (is (string= (d:uri (first (d:psis fourth-node))) + "http://test-tm/fourth-node")) + (is (= (length (d:psis fifth-node)) 1)) + (is (string= (d:uri (first (d:psis fifth-node))) + "http://test-tm/fifth-node")) + (is (= (length (d:psis item-1)) 1)) + (is (string= (d:uri (first (d:psis item-1))) + "http://test-tm/item-1")) + (is (= (length (d:psis item-2)) 1)) + (is (string= (d:uri (first (d:psis item-2))) + "http://test-tm/item-2")) + (is (= (length (d:psis arc1)) 1)) + (is (string= (d:uri (first (d:psis arc1))) + "http://test/arcs/arc1")) + (is (= (length (d:psis arc2)) 1)) + (is (string= (d:uri (first (d:psis arc2))) + "http://test/arcs/arc2")) + (is (= (length (d:psis arc3)) 1)) + (is (string= (d:uri (first (d:psis arc3))) + "http://test/arcs/arc3")) + (is (= (length (d:psis arc4)) 1)) + (is (string= (d:uri (first (d:psis arc4))) + "http://test/arcs/arc4")) + (is (= (length (d:psis arc5)) 1)) + (is (string= (d:uri (first (d:psis arc5))) + "http://test/arcs/arc5")) + (is (= (length (d:psis arc6)) 1)) + (is (string= (d:uri (first (d:psis arc6))) + "http://test/arcs/arc6")) + (is (= (length (d:psis arc7)) 1)) + (is (string= (d:uri (first (d:psis arc7))) + "http://test/arcs/arc7")) + (is (= (length (d:psis arc8)) 1)) + (is (string= (d:uri (first (d:psis arc8))) + "http://test/arcs/arc8")) + (is (= (length (d:psis rdf-first)) 1)) + (is (string= (d:uri (first (d:psis rdf-first))) + constants:*rdf-first*)) + (is (= (length (d:psis rdf-rest)) 1)) + (is (string= (d:uri (first (d:psis rdf-rest))) + constants:*rdf-rest*)) + (is (= (length (d:psis rdf-nil)) 1)) + (is (string= (d:uri (first (d:psis rdf-nil))) + constants:*rdf-nil*)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) + 1)) + (is (string= (d:charvalue (first (elephant:get-instances-by-class + 'd:OccurrenceC))) + "123")) + (is (string= (d:datatype (first (elephant:get-instances-by-class + 'd:OccurrenceC))) + "http://test-tm/long")) + (is (= (length (d:occurrences first-node)) 1)) + (is (= (length (d:player-in-roles first-node)) 3)) + (is (= (count-if + #'(lambda(x) + (or (and (eql (d:instance-of x) instance) + (eql (d:instance-of (d:parent x)) + type-instance)) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc1)) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc3)))) + (d:player-in-roles first-node)) + 3)) + (is (= (length (d:player-in-roles second-node)) 1)) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) type) + (eql (d:instance-of (d:parent x)) + type-instance))) + (d:player-in-roles second-node))) + (is (= (length (d:player-in-roles third-node)) 1)) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) object) + (eql (d:instance-of (d:parent x)) + arc1))) + (d:player-in-roles third-node))) + (let ((uuid-1 + (d:player + (find-if + #'(lambda(y) + (and (eql (d:instance-of y) object) + (= 0 (length (d:psis (d:player y)))))) + (d:roles + (d:parent + (find-if #'(lambda(x) - (or (and (eql (d:instance-of x) instance) - (eql (d:instance-of (d:parent x)) - type-instance)) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc1)) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc3)))) - (d:player-in-roles first-node)) - 3)) - (is (= (length (d:player-in-roles second-node)) 1)) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc3))) + (d:player-in-roles first-node)))))))) + (is-true uuid-1) + (is (= (length (d:player-in-roles uuid-1)) 2)) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc4))) + (d:player-in-roles uuid-1))) + (let ((col-1 + (d:player + (find-if + #'(lambda(y) + (and (eql (d:instance-of y) object) + (= 0 (length (d:psis (d:player y)))))) + (d:roles + (d:parent + (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc4))) + (d:player-in-roles uuid-1)))))))) + (is-true col-1) + (is (= (length (d:player-in-roles col-1)) 3)) (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) type) - (eql (d:instance-of (d:parent x)) - type-instance))) - (d:player-in-roles second-node))) - (is (= (length (d:player-in-roles third-node)) 1)) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) + rdf-first))) + (d:player-in-roles col-1))) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) + rdf-rest))) + (d:player-in-roles col-1))) (is-true (find-if #'(lambda(x) (and (eql (d:instance-of x) object) - (eql (d:instance-of (d:parent x)) - arc1))) - (d:player-in-roles third-node))) - (let ((uuid-1 - (d:player - (find-if - #'(lambda(y) - (and (eql (d:instance-of y) object) - (= 0 (length (d:psis (d:player y)))))) - (d:roles - (d:parent - (find-if + (eql (d:instance-of (d:parent x)) + arc4))) + (d:player-in-roles col-1))) + (is (= (length (d:player-in-roles item-1)) 1)) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) object) + (eql (d:instance-of (d:parent x)) + rdf-first))) + (d:player-in-roles item-1))) + (let ((col-2 + (let ((role + (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) + rdf-rest))) + (d:player-in-roles col-1)))) + (is (= (length (d:roles (d:parent role))) 2)) + (let ((other-role + (find-if #'(lambda(x) + (and (not (eql x role)) + (eql (d:instance-of x) + object))) + (d:roles (d:parent role))))) + (d:player other-role))))) + (is-true col-2) + (is (= (length (d:psis col-2)) 0)) + (is (= (length (d:player-in-roles col-2)) 3)) + (is-true (find-if #'(lambda(x) (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc3))) - (d:player-in-roles first-node)))))))) - (is-true uuid-1) - (is (= (length (d:player-in-roles uuid-1)) 2)) + (eql (d:instance-of (d:parent x)) + rdf-first))) + (d:player-in-roles col-2))) (is-true (find-if #'(lambda(x) (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc4))) - (d:player-in-roles uuid-1))) - (let ((col-1 - (d:player - (find-if - #'(lambda(y) - (and (eql (d:instance-of y) object) - (= 0 (length (d:psis (d:player y)))))) - (d:roles - (d:parent - (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc4))) - (d:player-in-roles uuid-1)))))))) - (is-true col-1) - (is (= (length (d:player-in-roles col-1)) 3)) - (is-true (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) - rdf-first))) - (d:player-in-roles col-1))) - (is-true (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) - rdf-rest))) - (d:player-in-roles col-1))) - (is-true (find-if - #'(lambda(x) - (and (eql (d:instance-of x) object) - (eql (d:instance-of (d:parent x)) - arc4))) - (d:player-in-roles col-1))) - (is (= (length (d:player-in-roles item-1)) 1)) - (is-true (find-if - #'(lambda(x) - (and (eql (d:instance-of x) object) - (eql (d:instance-of (d:parent x)) - rdf-first))) - (d:player-in-roles item-1))) - (let ((col-2 - (let ((role + (eql (d:instance-of (d:parent x)) + rdf-rest))) + (d:player-in-roles col-2))) + (let ((col-3 + (let ((role + (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) + rdf-rest))) + (d:player-in-roles col-2)))) + + (is (= (length (d:roles (d:parent role))) 2)) + (let ((other-role (find-if #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) - rdf-rest))) - (d:player-in-roles col-1)))) - (is (= (length (d:roles (d:parent role))) 2)) - (let ((other-role - (find-if #'(lambda(x) - (and (not (eql x role)) - (eql (d:instance-of x) - object))) - (d:roles (d:parent role))))) - (d:player other-role))))) - (is-true col-2) - (is (= (length (d:psis col-2)) 0)) - (is (= (length (d:player-in-roles col-2)) 3)) - (is-true (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) - rdf-first))) - (d:player-in-roles col-2))) - (is-true (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) - rdf-rest))) - (d:player-in-roles col-2))) - (let ((col-3 - (let ((role - (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) - rdf-rest))) - (d:player-in-roles col-2)))) - - (is (= (length (d:roles (d:parent role))) 2)) - (let ((other-role - (find-if - #'(lambda(x) - (not (eql x role))) - (d:roles (d:parent role))))) - (d:player other-role))))) - (is-true col-3) - (is (= (length (d:psis col-3)) 1)) - (is (string= (d:uri (first (d:psis col-3))) - constants:*rdf-nil*)) - (is (= (length (d:player-in-roles col-3)) 2))))) - (is (= (length (d:player-in-roles item-1)) 1)) - (is (= (length (d:player-in-roles item-2)) 2)) - (is-true (find-if - #'(lambda(x) + (not (eql x role))) + (d:roles (d:parent role))))) + (d:player other-role))))) + (is-true col-3) + (is (= (length (d:psis col-3)) 1)) + (is (string= (d:uri (first (d:psis col-3))) + constants:*rdf-nil*)) + (is (= (length (d:player-in-roles col-3)) 2))))) + (is (= (length (d:player-in-roles item-1)) 1)) + (is (= (length (d:player-in-roles item-2)) 2)) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc5))) + (d:player-in-roles item-2))) + (let ((uuid-2 + (d:player + (find-if + #'(lambda(y) + (and (eql (d:instance-of y) object) + (= 0 (length (d:psis (d:player y)))))) + (d:roles + (d:parent + (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc5))) + (d:player-in-roles item-2)))))))) + (is-true uuid-2) + (is (= (length (d:player-in-roles uuid-2)) 4)) + (is (= (count-if + #'(lambda(x) + (or (and (eql (d:instance-of x) object) + (eql (d:instance-of (d:parent x)) arc5)) (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc5))) - (d:player-in-roles item-2))) - (let ((uuid-2 - (d:player - (find-if - #'(lambda(y) - (and (eql (d:instance-of y) object) - (= 0 (length (d:psis (d:player y)))))) - (d:roles - (d:parent - (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc5))) - (d:player-in-roles item-2)))))))) - (is-true uuid-2) - (is (= (length (d:player-in-roles uuid-2)) 4)) - (is (= (count-if + (or + (eql (d:instance-of (d:parent x)) arc6) + (eql (d:instance-of (d:parent x)) arc7) + (eql (d:instance-of + (d:parent x)) arc8))))) + (d:player-in-roles uuid-2)) + 4)) + (is (= (length (d:player-in-roles fourth-node)) 1)) + (is (= (length (d:player-in-roles fifth-node)) 1)) + (let ((col-2 + (d:player + (find-if + #'(lambda(y) + (and (eql (d:instance-of y) object) + (= 1 (length (d:psis (d:player y)))))) + (d:roles + (d:parent + (find-if #'(lambda(x) - (or (and (eql (d:instance-of x) object) - (eql (d:instance-of (d:parent x)) arc5)) - (and (eql (d:instance-of x) subject) - (or - (eql (d:instance-of (d:parent x)) arc6) - (eql (d:instance-of (d:parent x)) arc7) - (eql (d:instance-of - (d:parent x)) arc8))))) - (d:player-in-roles uuid-2)) - 4)) - (is (= (length (d:player-in-roles fourth-node)) 1)) - (is (= (length (d:player-in-roles fifth-node)) 1)) - (let ((col-2 - (d:player - (find-if - #'(lambda(y) - (and (eql (d:instance-of y) object) - (= 1 (length (d:psis (d:player y)))))) - (d:roles - (d:parent - (find-if - #'(lambda(x) - (and (eql (d:instance-of x) subject) - (eql (d:instance-of (d:parent x)) arc8))) - (d:player-in-roles uuid-2)))))))) - (is (= (length (d:psis col-2)) 1)) - (is (string= constants:*rdf-nil* - (d:uri (first (d:psis col-2))))) - (is-true col-2) - (is (= (length (d:player-in-roles col-2)) 2))))))))) + (and (eql (d:instance-of x) subject) + (eql (d:instance-of (d:parent x)) arc8))) + (d:player-in-roles uuid-2)))))))) + (is (= (length (d:psis col-2)) 1)) + (is (string= constants:*rdf-nil* + (d:uri (first (d:psis col-2))))) + (is-true col-2) + (is (= (length (d:player-in-roles col-2)) 2))))))))) (elephant:close-store)) @@ -1602,7 +1590,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "firstName")) + (concat arcs "firstName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) (= (length (d:psis (d:parent x))) 1) @@ -1614,7 +1602,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "lastName")) + (concat arcs "lastName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) (= (length (d:psis (d:parent x))) 1) @@ -1626,7 +1614,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "fullName")) + (concat arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) (= (length (d:psis (d:parent x))) 1) @@ -1638,7 +1626,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "fullName")) + (concat arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) (= (length (d:psis (d:parent x))) 1) @@ -1650,7 +1638,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "nativeName")) + (concat arcs "nativeName")) (string= *xml-string* (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) @@ -1663,7 +1651,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "title")) + (concat arcs "title")) (string= *xml-string* (d:datatype x)) (string= (d:charvalue x) "Der Zauberlehrling") (= 1 (length (d:themes x))) @@ -1677,7 +1665,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "title")) + (concat arcs "title")) (= 0 (length (d:themes x))) (string= (d:charvalue x) "Prometheus") (string= *xml-string* (d:datatype x)) @@ -1690,7 +1678,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "title")) + (concat arcs "title")) (string= *xml-string* (d:datatype x)) (string= (d:charvalue x) "Der Erlkönig") (= 1 (length (d:themes x))) @@ -1704,7 +1692,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "content")) + (concat arcs "content")) (string= *xml-string* (d:datatype x)) (string= (d:charvalue x) "Hat der alte Hexenmeister ...") (= 1 (length (d:themes x))) @@ -1718,7 +1706,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "content")) + (concat arcs "content")) (string= *xml-string* (d:datatype x)) (string= (d:charvalue x) " Bedecke deinen Himmel, Zeus, ... ") @@ -1733,7 +1721,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "content")) + (concat arcs "content")) (string= *xml-string* (d:datatype x)) (string= (d:charvalue x) "Wer reitet so spät durch Nacht und Wind? ...") @@ -1748,7 +1736,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "population")) + (concat arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) (= (length (d:psis (d:parent x))) 1) @@ -1760,7 +1748,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "population")) + (concat arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) (= (length (d:psis (d:parent x))) 1) @@ -1772,7 +1760,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "population")) + (concat arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) (= (length (d:psis (d:parent x))) 1) @@ -1784,7 +1772,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "population")) + (concat arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) (= (length (d:psis (d:parent x))) 1) @@ -1796,7 +1784,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "date")) + (concat arcs "date")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) (= (length (d:psis (d:parent x))) 0))) @@ -1806,7 +1794,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "start")) + (concat arcs "start")) (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) @@ -1818,7 +1806,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "start")) + (concat arcs "start")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) (= (length (d:psis (d:parent x))) 0))) @@ -1829,7 +1817,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "end")) + (concat arcs "end")) (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) @@ -1840,7 +1828,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "end")) + (concat arcs "end")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) (= (length (d:psis (d:parent x))) 0))) @@ -1869,7 +1857,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "born")) + (concat arcs "born")) (= (length (d:roles x)) 2) (find-if #'(lambda(y) @@ -1889,7 +1877,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "died")) + (concat arcs "died")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -1908,7 +1896,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "wrote")) + (concat arcs "wrote")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -1927,7 +1915,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "capital")) + (concat arcs "capital")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -1948,7 +1936,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "officialese")) + (concat arcs "officialese")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -1969,7 +1957,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "place")) + (concat arcs "place")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-object) @@ -1988,7 +1976,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "place")) + (concat arcs "place")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-object) @@ -2007,7 +1995,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "locatedIn")) + (concat arcs "locatedIn")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2028,7 +2016,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "locatedIn")) + (concat arcs "locatedIn")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2049,7 +2037,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "locatedIn")) + (concat arcs "locatedIn")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2070,7 +2058,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "dateRange")) + (concat arcs "dateRange")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2089,7 +2077,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "dateRange")) + (concat arcs "dateRange")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2108,7 +2096,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string arcs "dateRange")) + (concat arcs "dateRange")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2127,7 +2115,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string constants:*rdf-ns* "_1")) + (concat constants:*rdf-ns* "_1")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2146,7 +2134,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string constants:*rdf-ns* "_2")) + (concat constants:*rdf-ns* "_2")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2165,7 +2153,7 @@ #'(lambda(x) (and (= (length (d:psis (d:instance-of x))) 1) (string= (d:uri (first (d:psis (d:instance-of x)))) - (concatenate 'string constants:*rdf-ns* "_3")) + (concat constants:*rdf-ns* "_3")) (find-if #'(lambda(y) (and (eql (d:instance-of y) isi-subject) @@ -2204,7 +2192,7 @@ (german "http://some.where/language/German") (author "http://some.where/types/Author") (goethe "http://some.where/author/Goethe") - (bag (concatenate 'string constants::*rdf-ns* "Bag")) + (bag (concat constants::*rdf-ns* "Bag")) (poem "http://some.where/types/Poem") (ballad "http://some.where/types/Ballad") (zauberlehrling "http://some.where/poem/Der_Zauberlehrling") @@ -2465,101 +2453,101 @@ (let ((arcs "http://some.where/relationship/") (types "http://some.where/types/")) (let ((goethe (get-item-by-id "http://some.where/author/Goethe")) - (author (get-item-by-id (concatenate 'string types "Author"))) + (author (get-item-by-id (concat types "Author"))) (first-name (get-item-by-id - (concatenate 'string arcs "firstName"))) + (concat arcs "firstName"))) (last-name (get-item-by-id - (concatenate 'string arcs "lastName"))) - (born (get-item-by-id (concatenate 'string arcs "born"))) - (event (get-item-by-id (concatenate 'string types "Event"))) - (date (get-item-by-id (concatenate 'string arcs "date"))) - (place (get-item-by-id (concatenate 'string arcs "place"))) + (concat arcs "lastName"))) + (born (get-item-by-id (concat arcs "born"))) + (event (get-item-by-id (concat types "Event"))) + (date (get-item-by-id (concat arcs "date"))) + (place (get-item-by-id (concat arcs "place"))) (frankfurt (get-item-by-id "http://some.where/metropolis/FrankfurtMain")) - (metropolis (get-item-by-id (concatenate 'string types + (metropolis (get-item-by-id (concat types "Metropolis"))) - (region (get-item-by-id (concatenate 'string types "Region"))) - (population (get-item-by-id (concatenate 'string arcs + (region (get-item-by-id (concat types "Region"))) + (population (get-item-by-id (concat arcs "population"))) - (locatedIn (get-item-by-id (concatenate 'string arcs + (locatedIn (get-item-by-id (concat arcs "locatedIn"))) (germany (get-item-by-id "http://some.where/country/Germany")) - (country (get-item-by-id (concatenate 'string types "Country"))) - (native-name (get-item-by-id (concatenate 'string arcs + (country (get-item-by-id (concat types "Country"))) + (native-name (get-item-by-id (concat arcs "nativeName"))) - (officialese (get-item-by-id (concatenate 'string arcs + (officialese (get-item-by-id (concat arcs "officialese"))) (german (get-item-by-id "http://some.where/language/German")) - (capital (get-item-by-id (concatenate 'string arcs "capital"))) + (capital (get-item-by-id (concat arcs "capital"))) (berlin (get-item-by-id "http://some.where/metropolis/Berlin")) - (died (get-item-by-id (concatenate 'string arcs "died"))) + (died (get-item-by-id (concat arcs "died"))) (weimar (get-item-by-id "http://some.where/city/Weimar")) - (city (get-item-by-id (concatenate 'string types "City"))) - (wrote (get-item-by-id (concatenate 'string arcs "wrote"))) + (city (get-item-by-id (concat types "City"))) + (wrote (get-item-by-id (concat arcs "wrote"))) (goethe-literature (get-item-by-id "goethe_literature")) - (bag (get-item-by-id (concatenate 'string *rdf-ns* "Bag"))) - (_1 (get-item-by-id (concatenate 'string *rdf-ns* "_1"))) - (_2 (get-item-by-id (concatenate 'string *rdf-ns* "_2"))) - (_3 (get-item-by-id (concatenate 'string *rdf-ns* "_3"))) + (bag (get-item-by-id (concat *rdf-ns* "Bag"))) + (_1 (get-item-by-id (concat *rdf-ns* "_1"))) + (_2 (get-item-by-id (concat *rdf-ns* "_2"))) + (_3 (get-item-by-id (concat *rdf-ns* "_3"))) (zauberlehrling (get-item-by-id "http://some.where/poem/Der_Zauberlehrling")) - (poem (get-item-by-id (concatenate 'string types "Poem"))) - (dateRange (get-item-by-id (concatenate 'string arcs "dateRange"))) - (start (get-item-by-id (concatenate 'string arcs "start"))) - (end (get-item-by-id (concatenate 'string arcs "end"))) - (title (get-item-by-id (concatenate 'string arcs "title"))) - (content (get-item-by-id (concatenate 'string arcs "content"))) + (poem (get-item-by-id (concat types "Poem"))) + (dateRange (get-item-by-id (concat arcs "dateRange"))) + (start (get-item-by-id (concat arcs "start"))) + (end (get-item-by-id (concat arcs "end"))) + (title (get-item-by-id (concat arcs "title"))) + (content (get-item-by-id (concat arcs "content"))) (erlkoenig (get-item-by-id "http://some.where/ballad/Der_Erlkoenig")) - (ballad (get-item-by-id (concatenate 'string types "Ballad"))) + (ballad (get-item-by-id (concat types "Ballad"))) (de (get-item-by-id (concatenate 'string constants::*rdf2tm-scope-prefix* "de"))) (prometheus (get-item-by-id "http://some.where/poem/Prometheus")) - (language (get-item-by-id (concatenate 'string types "Language"))) - (full-name (get-item-by-id (concatenate 'string arcs "fullName")))) + (language (get-item-by-id (concat types "Language"))) + (full-name (get-item-by-id (concat arcs "fullName")))) (check-topic goethe "http://some.where/author/Goethe") - (check-topic author (concatenate 'string types "Author")) - (check-topic first-name (concatenate 'string arcs "firstName")) - (check-topic last-name (concatenate 'string arcs "lastName")) - (check-topic born (concatenate 'string arcs "born")) - (check-topic event (concatenate 'string types "Event")) - (check-topic date (concatenate 'string arcs "date")) - (check-topic place (concatenate 'string arcs "place")) + (check-topic author (concat types "Author")) + (check-topic first-name (concat arcs "firstName")) + (check-topic last-name (concat arcs "lastName")) + (check-topic born (concat arcs "born")) + (check-topic event (concat types "Event")) + (check-topic date (concat arcs "date")) + (check-topic place (concat arcs "place")) (check-topic frankfurt "http://some.where/metropolis/FrankfurtMain") - (check-topic metropolis (concatenate 'string types "Metropolis")) - (check-topic region (concatenate 'string types "Region")) - (check-topic population (concatenate 'string arcs "population")) - (check-topic locatedIn (concatenate 'string arcs "locatedIn")) + (check-topic metropolis (concat types "Metropolis")) + (check-topic region (concat types "Region")) + (check-topic population (concat arcs "population")) + (check-topic locatedIn (concat arcs "locatedIn")) (check-topic germany "http://some.where/country/Germany") - (check-topic country (concatenate 'string types "Country")) - (check-topic native-name (concatenate 'string arcs "nativeName")) - (check-topic officialese (concatenate 'string arcs "officialese")) + (check-topic country (concat types "Country")) + (check-topic native-name (concat arcs "nativeName")) + (check-topic officialese (concat arcs "officialese")) (check-topic german "http://some.where/language/German") - (check-topic capital (concatenate 'string arcs "capital")) + (check-topic capital (concat arcs "capital")) (check-topic berlin "http://some.where/metropolis/Berlin") - (check-topic died (concatenate 'string arcs "died")) + (check-topic died (concat arcs "died")) (check-topic weimar "http://some.where/city/Weimar") - (check-topic city (concatenate 'string types "City")) - (check-topic wrote (concatenate 'string arcs "wrote")) + (check-topic city (concat types "City")) + (check-topic wrote (concat arcs "wrote")) (check-topic goethe-literature nil) - (check-topic bag (concatenate 'string *rdf-ns* "Bag")) - (check-topic _1 (concatenate 'string *rdf-ns* "_1")) - (check-topic _2 (concatenate 'string *rdf-ns* "_2")) - (check-topic _3 (concatenate 'string *rdf-ns* "_3")) + (check-topic bag (concat *rdf-ns* "Bag")) + (check-topic _1 (concat *rdf-ns* "_1")) + (check-topic _2 (concat *rdf-ns* "_2")) + (check-topic _3 (concat *rdf-ns* "_3")) (check-topic zauberlehrling "http://some.where/poem/Der_Zauberlehrling") - (check-topic poem (concatenate 'string types "Poem")) - (check-topic dateRange (concatenate 'string arcs "dateRange")) - (check-topic start (concatenate 'string arcs "start")) - (check-topic end (concatenate 'string arcs "end")) - (check-topic title (concatenate 'string arcs "title")) - (check-topic content (concatenate 'string arcs "content")) + (check-topic poem (concat types "Poem")) + (check-topic dateRange (concat arcs "dateRange")) + (check-topic start (concat arcs "start")) + (check-topic end (concat arcs "end")) + (check-topic title (concat arcs "title")) + (check-topic content (concat arcs "content")) (check-topic erlkoenig "http://some.where/ballad/Der_Erlkoenig") - (check-topic ballad (concatenate 'string types "Ballad")) - (check-topic de (concatenate 'string constants::*rdf2tm-scope-prefix* + (check-topic ballad (concat types "Ballad")) + (check-topic de (concat constants::*rdf2tm-scope-prefix* "de")) (check-topic prometheus "http://some.where/poem/Prometheus") - (check-topic language (concatenate 'string types "Language")) - (check-topic full-name (concatenate 'string arcs "fullName")) + (check-topic language (concat types "Language")) + (check-topic full-name (concat arcs "fullName")) (is (= (count-if #'(lambda(x) (null (d:psis x))) (elephant:get-instances-by-class 'd:TopicC)) @@ -2573,12 +2561,12 @@ (revision-1 100) (document-id "doc-id") (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\">" - " <rdf:Description rdf:about=\"first-node\">" - " <arcs:arc rdf:parseType=\"Collection\" />" - " </rdf:Description>" - "</rdf:RDF>"))) + (concat "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\">" + " <rdf:Description rdf:about=\"first-node\">" + " <arcs:arc rdf:parseType=\"Collection\" />" + " </rdf:Description>" + "</rdf:RDF>"))) (let ((rdf-node (elt (dom:child-nodes (cxml:parse doc-1 (cxml-dom:make-dom-builder))) 0))) @@ -2633,15 +2621,15 @@ (revision-1 100) (document-id "doc-id") (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\">" - " <rdf:Description rdf:about=\"first-node\">" - " <arcs:arc rdf:parseType=\"Collection\">" - " <rdf:Description rdf:about=\"item-1\"/>" - " <arcs:Node rdf:about=\"item-2\"/>" - " </arcs:arc>" - " </rdf:Description>" - "</rdf:RDF>"))) + (concat "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\">" + " <rdf:Description rdf:about=\"first-node\">" + " <arcs:arc rdf:parseType=\"Collection\">" + " <rdf:Description rdf:about=\"item-1\"/>" + " <arcs:Node rdf:about=\"item-2\"/>" + " </arcs:arc>" + " </rdf:Description>" + "</rdf:RDF>"))) (let ((rdf-node (elt (dom:child-nodes (cxml:parse doc-1 (cxml-dom:make-dom-builder))) 0))) @@ -2790,12 +2778,12 @@ (test test-xml-base "Tests the function get-xml-base." (let ((doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\">" - " <rdf:Description xml:base=\"http://base-1\"/>" - " <rdf:Description xml:base=\"http://base-2#\"/>" - " <rdf:Description xml:base=\"http://base-3/\"/>" - "</rdf:RDF>"))) + (concat "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\">" + " <rdf:Description xml:base=\"http://base-1\"/>" + " <rdf:Description xml:base=\"http://base-2#\"/>" + " <rdf:Description xml:base=\"http://base-3/\"/>" + "</rdf:RDF>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) (let ((n-1 (elt (rdf-importer::child-nodes-or-text rdf-node Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Wed Jan 5 18:37:15 2011 @@ -14,6 +14,7 @@ :it.bese.FiveAM :unittests-constants :fixtures + :base-tools :exporter) (:import-from :constants *xtm2.0-ns* @@ -531,26 +532,26 @@ (revision-1 100) (document-id "doc-id") (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " - "xmlns:arcs=\"http://test/arcs/\" " - "xmlns:rdfs=\"" *rdfs-ns* "\">" - "<rdf:Description rdf:about=\"first-node\">" - "<arcs:arc1 rdf:ID=\"reification-1\">" - "<rdf:Description rdf:about=\"second-node\" />" - "</arcs:arc1>" - "</rdf:Description>" - "<rdf:Description rdf:ID=\"#reification-1\">" - "<arcs:arc2 rdf:resource=\"third-node\"/>" - "</rdf:Description>" - "<rdf:Description rdf:nodeID=\"fourth-node\">" - "<arcs:arc3 rdf:ID=\"reification-2\" rdf:datatype=\"dt\">" - "occurrence data" - "</arcs:arc3>" - "</rdf:Description>" - "<rdf:Description rdf:ID=\"#reification-2\">" - "<arcs:arc4 rdf:resource=\"fifth-node\" />" - "</rdf:Description>" - "</rdf:RDF>"))) + (concat "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "xmlns:rdfs=\"" *rdfs-ns* "\">" + "<rdf:Description rdf:about=\"first-node\">" + "<arcs:arc1 rdf:ID=\"reification-1\">" + "<rdf:Description rdf:about=\"second-node\" />" + "</arcs:arc1>" + "</rdf:Description>" + "<rdf:Description rdf:ID=\"#reification-1\">" + "<arcs:arc2 rdf:resource=\"third-node\"/>" + "</rdf:Description>" + "<rdf:Description rdf:nodeID=\"fourth-node\">" + "<arcs:arc3 rdf:ID=\"reification-2\" rdf:datatype=\"dt\">" + "occurrence data" + "</arcs:arc3>" + "</rdf:Description>" + "<rdf:Description rdf:ID=\"#reification-2\">" + "<arcs:arc4 rdf:resource=\"fifth-node\" />" + "</rdf:Description>" + "</rdf:RDF>"))) (clean-out-db db-dir) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is-true dom-1) @@ -685,17 +686,17 @@ (is-true (reified-construct (reifier name))) (is (= (length (psis (reifier name))) 1)) (is (string= (uri (first (psis (reifier name)))) - (concatenate 'string tm-id "lisa-name"))) + (concat tm-id "lisa-name"))) (is-true (reifier variant)) (is-true (reified-construct (reifier variant))) (is (= (length (psis (reifier variant))) 1)) (is (string= (uri (first (psis (reifier variant)))) - (concatenate 'string tm-id "lisa-name-variant"))) + (concat tm-id "lisa-name-variant"))) (is-true (reifier occurrence)) (is-true (reified-construct (reifier occurrence))) (is (= (length (psis (reifier occurrence))) 1)) (is (string= (uri (first (psis (reifier occurrence)))) - (concatenate 'string tm-id "lisa-occurrence"))))))) + (concat tm-id "lisa-occurrence"))))))) (elephant:close-store)) @@ -722,7 +723,7 @@ (is-true (reified-construct (reifier friendship-association))) (is (= (length (psis (reifier friendship-association))) 1)) (is (string= (uri (first (psis (reifier friendship-association)))) - (concatenate 'string tm-id "friendship-association"))) + (concat tm-id "friendship-association"))) (is (= (length (roles friendship-association)) 2)) (let ((carl-role (find-if #'(lambda(role) @@ -733,7 +734,7 @@ (is-true (reified-construct (reifier carl-role))) (is (= (length (psis (reifier carl-role))) 1)) (is (string= (uri (first (psis (reifier carl-role)))) - (concatenate 'string tm-id "friend-role"))))))) + (concat tm-id "friend-role"))))))) (elephant:close-store)) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Jan 5 18:37:15 2011 @@ -168,15 +168,14 @@ (let ((query-1 " \"literal-value\"@de.") (query-2 "true.") (query-3 "false}") - (query-4 (concatenate 'string "1234.43e10" (string #\tab))) - (query-5 (concatenate 'string "'''true'''^^" *xml-boolean* " ;")) - (query-6 (concatenate 'string "'123.4'^^" *xml-double* - "." (string #\newline))) + (query-4 (concat "1234.43e10" (string #\tab))) + (query-5 (concat "'''true'''^^" *xml-boolean* " ;")) + (query-6 (concat "'123.4'^^" *xml-double* "." (string #\newline))) (query-7 "\"Just a test literal with some \\\"quoted\\\" words!\"@en.") - (query-8 (concatenate 'string "'''12.4'''^^" *xml-integer* ". ")) - (query-9 (concatenate 'string "\"13e4\"^^" *xml-boolean* " .")) + (query-8 (concat "'''12.4'''^^" *xml-integer* ". ")) + (query-9 (concat "\"13e4\"^^" *xml-boolean* " .")) (dummy-object (make-instance 'SPARQL-Query :query ""))) (is-true dummy-object) (let ((res (tm-sparql::parse-literal-elem dummy-object query-1))) @@ -218,7 +217,7 @@ (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) (let ((res (tm-sparql::parse-literal-elem dummy-object query-6))) (is (string= (getf res :next-query) - (concatenate 'string "." (string #\newline)))) + (concat "." (string #\newline)))) (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)) @@ -346,13 +345,13 @@ (test test-parse-group-2 "Test various functionality of several functions responsible for parsing the SELECT-WHERE-statement." - (let ((query-4 (concatenate 'string "<subject> <predicate> '''true'''^^" - *xml-boolean* "; pref:predicate-2 \"12\"^^" - *xml-integer* "}")) - (query-5 (concatenate 'string "<subject> <predicate> '''false'''^^" - *xml-boolean* "; BASE <http://new.base/>" - "<predicate-2> \"abc\"^^" - *xml-string* "}")) + (let ((query-4 (concat "<subject> <predicate> '''true'''^^" + *xml-boolean* "; pref:predicate-2 \"12\"^^" + *xml-integer* "}")) + (query-5 (concat "<subject> <predicate> '''false'''^^" + *xml-boolean* "; BASE <http://new.base/>" + "<predicate-2> \"abc\"^^" + *xml-string* "}")) (dummy-object (make-instance 'SPARQL-Query :query "" :base "http://base.value/")) (lit 'TM-SPARQL::LITERAL) Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Wed Jan 5 18:37:15 2011 @@ -51,12 +51,12 @@ of the type rdf:_n there will be returned rdf:li." (let ((rdf-len (length *rdf-ns*))) (let ((prep-uri (when (string-starts-with - uri (concatenate 'string *rdf-ns* "_")) + uri (concat *rdf-ns* "_")) (subseq uri (+ rdf-len 1))))) (if prep-uri (handler-case (progn (parse-integer prep-uri) - (concatenate 'string *rdf-ns* "li")) + (concat *rdf-ns* "li")) (condition () uri)) uri)))) @@ -86,8 +86,7 @@ (let ((ns (getf ns-list :prefix)) (tag-name (getf ns-list :suffix))) (cxml:with-namespace ((get-ns-prefix ns) ns) - (cxml:with-element (concatenate 'string (get-ns-prefix ns) - ":" tag-name) + (cxml:with-element (concat (get-ns-prefix ns) ":" tag-name) ,@body))))) @@ -154,9 +153,8 @@ *ns-map*))) (if ns-entry (getf ns-entry :prefix) - (let ((new-name (concatenate - 'string "ns" - (write-to-string (+ 1 (length *ns-map*)))))) + (let ((new-name (concat "ns" + (write-to-string (+ 1 (length *ns-map*)))))) (push (list :prefix new-name :uri ns-uri) *ns-map*) @@ -209,7 +207,7 @@ (defun make-object-id (object) "Returns a string of the form id_<integer> which can be used as nodeID." - (concatenate 'string "id_" (write-to-string (elephant::oid object)))) + (concat "id_" (write-to-string (elephant::oid object)))) (defun make-topic-reference (topic) @@ -221,7 +219,7 @@ (if (reified-construct topic) (let ((psi (get-reifier-psi topic))) (if psi - (concatenate 'string "#" (get-reifier-uri topic)) + (concat "#" (get-reifier-uri topic)) (uri (first (psis topic))))) (uri (first (psis topic))))) (cxml:attribute "rdf:nodeID" (make-object-id topic)))) @@ -597,7 +595,8 @@ (if (reified-construct construct) (let ((reifier-uri (get-reifier-uri construct))) (if reifier-uri - (cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct))) + (cxml:attribute "rdf:about" + (concat "#" (get-reifier-uri construct))) (cxml:attribute "rdf:about" (uri psi)))) (cxml:attribute "rdf:about" (uri psi))) (cxml:attribute "rdf:nodeID" (make-object-id construct))) @@ -632,7 +631,8 @@ (if (reified-construct construct) (let ((reifier-uri (get-reifier-uri construct))) (if reifier-uri - (cxml:attribute "rdf:about" (concatenate 'string "#" (get-reifier-uri construct))) + (cxml:attribute "rdf:about" + (concat "#" (get-reifier-uri construct))) (cxml:attribute "rdf:about" (uri psi)))) (cxml:attribute "rdf:about" (uri psi))) (cxml:attribute "rdf:nodeID" (make-object-id construct))) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Jan 5 18:37:15 2011 @@ -423,8 +423,7 @@ (let ((topic-id (or about ID nodeID UUID)) (psi-uri (or about ID)) (ii-uri (unless (or about ID) - (concatenate 'string *rdf2tm-blank-node-prefix* - (or nodeID UUID))))) + (concat *rdf2tm-blank-node-prefix* (or nodeID UUID))))) (let ((top (get-item-by-id topic-id :xtm-id document-id :revision start-revision))) (if top Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Wed Jan 5 18:37:15 2011 @@ -100,8 +100,8 @@ *_n-map*))) (if owner (let ((new-name - (concatenate - 'string *rdf-ns* "_" + (concat + *rdf-ns* "_" (write-to-string (+ (length (getf owner :props)) 1))))) (push (list :elem property :name new-name) @@ -112,7 +112,7 @@ (list :owner owner-identifier :props (list (list :elem property - :name (concatenate 'string *rdf-ns* "_1")))) + :name (concat *rdf-ns* "_1")))) *_n-map*) "_1")))))) @@ -183,15 +183,11 @@ (when (or resource datatype parseType class subClassOf) (error "~a~a is not allowed here (~a)!" err-pref (cond - (resource (concatenate 'string "resource(" - resource ")")) - (datatype (concatenate 'string "datatype(" - datatype ")")) - (parseType (concatenate 'string "parseType(" - parseType ")")) - (class (concatenate 'string "Class(" class ")")) - (subClassOf (concatenate 'string "subClassOf(" - subClassOf ")"))) + (resource (concat "resource(" resource ")")) + (datatype (concat "datatype(" datatype ")")) + (parseType (concat "parseType(" parseType ")")) + (class (concat "Class(" class ")")) + (subClassOf (concat "subClassOf(" subClassOf ")"))) (dom:node-name node))) (dolist (item *rdf-types*) (when (get-ns-attribute node item) @@ -310,9 +306,9 @@ (error "~aonly one of ~a and rdf:datatype (~a) is allowed!" err-pref (cond - (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")")) - (resource (concatenate 'string "rdf:resource (" resource ")")) - (type (concatenate 'string "rdf:type (" type ")")) + (nodeID (concat "rdf:nodeID (" nodeID ")")) + (resource (concat "rdf:resource (" resource ")")) + (type (concat "rdf:type (" type ")")) (literals literals)) datatype)) (when (and (or nodeID resource) @@ -320,8 +316,8 @@ (error "~awhen ~a is set no content is allowed: ~a!" err-pref (cond - (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")")) - (resource (concatenate 'string "rdf:resource (" resource ")"))) + (nodeID (concat "rdf:nodeID (" nodeID ")")) + (resource (concat "rdf:resource (" resource ")"))) content)) (when (and type (stringp content) @@ -340,8 +336,8 @@ (error "~a~a not allowed here!" err-pref (if about - (concatenate 'string "rdf:about (" about ")") - (concatenate 'string "rdfs:subClassOf (" subClassOf ")")))) + (concat "rdf:about (" about ")") + (concat "rdfs:subClassOf (" subClassOf ")")))) (when (and (string= node-name "subClassOf") (string= node-ns *rdfs-ns*) (not (or nodeID resource content))) @@ -424,8 +420,7 @@ (remove-if #'null (append (unless (string= (get-type-of-node-name elem) - (concatenate 'string *rdf-ns* - "Description")) + (concat *rdf-ns* "Description")) (list (list :topicid (get-type-of-node-name elem) :psi (get-type-of-node-name elem) Modified: trunk/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm1.0.lisp Wed Jan 5 18:37:15 2011 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :exporter - (:use :cl :cxml :elephant :datamodel :isidorus-threading) + (:use :cl :cxml :elephant :datamodel :isidorus-threading :base-tools) (:import-from :constants *XTM2.0-NS* *XTM1.0-NS* @@ -72,11 +72,14 @@ ""))) (if (string= characteristic-type "http://www.w3.org/2001/XMLSchema#anyURI") (cxml:with-element "t:resourceRef" - (cxml:attribute "xlink:href" - (let ((ref-topic (when (and (> (length characteristic-value) 0) - (eql (elt characteristic-value 0) #\#)) - (get-item-by-id (subseq characteristic-value 1) :revision revision)))) - (if ref-topic (concatenate 'string "#" (topic-id ref-topic revision)) characteristic-value)))) + (cxml:attribute + "xlink:href" + (let ((ref-topic (when (and (> (length characteristic-value) 0) + (eql (elt characteristic-value 0) #\#)) + (get-item-by-id (subseq characteristic-value 1) + :revision revision)))) + (if ref-topic (concat "#" (topic-id ref-topic revision)) + characteristic-value)))) (cxml:with-element "t:resourceData" (cxml:text characteristic-value))))) @@ -94,7 +97,7 @@ (type (or integer nil) revision)) (cxml:with-element "t:instanceOf" (cxml:with-element "t:topicRef" - (cxml:attribute "xlink:href" (concatenate 'string "#" (topic-id topic revision)))))) + (cxml:attribute "xlink:href" (concat "#" (topic-id topic revision)))))) (defun to-subjectIdentity-elem-xtm1.0 (psis locator revision) Modified: trunk/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm2.0.lisp Wed Jan 5 18:37:15 2011 @@ -90,7 +90,7 @@ :revision revision)))) (cxml:attribute "href" (if ref-topic - (concatenate 'string "#" (topic-id ref-topic revision)) + (concat "#" (topic-id ref-topic revision)) characteristic-value)))) (cxml:with-element "t:resourceData" (when (slot-boundp characteristic 'datatype) @@ -165,7 +165,7 @@ (cxml:with-element "t:instanceOf" (loop for item in ios do (cxml:with-element "t:topicRef" - (cxml:attribute "href" (concatenate 'string "#" (topic-id item revision)))))))) + (cxml:attribute "href" (concat "#" (topic-id item revision)))))))) (map 'list #'(lambda(x) (to-elem x revision)) (names topic :revision revision)) Modified: trunk/src/xml/xtm/importer.lisp ============================================================================== --- trunk/src/xml/xtm/importer.lisp (original) +++ trunk/src/xml/xtm/importer.lisp Wed Jan 5 18:37:15 2011 @@ -14,7 +14,7 @@ ;; raise some kind of error (--> condition) if something goes wrong. (defpackage :xml-importer - (:use :cl :cxml :elephant :datamodel :isidorus-threading) + (:use :cl :cxml :elephant :datamodel :isidorus-threading :base-tools) (:import-from :constants *type-instance-psi* *type-psi* Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Wed Jan 5 18:37:15 2011 @@ -19,7 +19,7 @@ (> (length reifier-uri) 0)) (let ((psi (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri - (concatenate 'string "#" reifier-uri)))) + (concat "#" reifier-uri)))) (when psi (let ((reifier-topic (identified-construct psi :revision start-revision))) (when reifier-topic Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Wed Jan 5 18:37:15 2011 @@ -40,7 +40,7 @@ (let ((prep-id (if (and (> (length id) 0) (eql (elt id 0) #\#)) id - (concatenate 'string "#" (string-left-trim "/" id))))) + (concat "#" (string-left-trim "/" id))))) (absolutize-value prep-id xml-base tm-id))) @@ -65,8 +65,8 @@ (let ((fragment (if (and (> (length prep-value) 0) (eql (elt prep-value 0) #\#)) - (concatenate 'string prep-base prep-value) - (concatenate 'string prep-base "/" prep-value)))) + (concat prep-base prep-value) + (concat prep-base "/" prep-value)))) (if (absolute-uri-p fragment) fragment (let ((prep-fragment @@ -79,7 +79,7 @@ (if (eql (elt prep-fragment 0) #\#) "" "/"))) - (concatenate 'string prep-tm-id separator prep-fragment)))))))) + (concat prep-tm-id separator prep-fragment)))))))) (defun get-xml-lang(elem &key (old-lang nil)) @@ -123,8 +123,8 @@ new-base (if (not new-base) old-base - (concatenate 'string (string-right-trim "/" old-base) - "/" (string-left-trim "/" new-base)))))) + (concat (string-right-trim "/" old-base) + "/" (string-left-trim "/" new-base)))))) (defun child-nodes-or-text (elem &key (trim nil)) @@ -170,7 +170,7 @@ "Returns the node's name without a prefix." (if (find #\: (dom:node-name elem)) (subseq (dom:node-name elem) - (length (concatenate 'string (dom:prefix elem) ":"))) + (length (concat (dom:prefix elem) ":"))) (dom:node-name elem))) @@ -190,17 +190,16 @@ (defun xpath-fn-string (elem &optional (strip-whitespace t)) "Extract the string value of an XML DOM element (with subelements)" (declare (dom:element elem)) - ;; ((conditional-fn #'(lambda(s) (string-trim " #\t#\n" s)) strip-whitespace ; (handle-whitespace strip-whitespace - (apply #'concatenate 'string - (map 'list - (lambda (s) - (cond - ((dom:text-node-p s) - (dom:node-value s)) - ((dom:element-p s) - (xpath-fn-string s)))) - (dom:child-nodes elem))))) + (apply #'concatenate 'string + (map 'list + (lambda (s) + (cond + ((dom:text-node-p s) + (dom:node-value s)) + ((dom:element-p s) + (xpath-fn-string s)))) + (dom:child-nodes elem))))) (defun attr-value (attr) (dom:node-value attr)) @@ -312,16 +311,15 @@ (attributes (dom:attributes elem)) (child-nodes (dom:child-nodes elem)) (elem-string "")) - (push-string (concatenate 'string "<" node-name) elem-string) + (push-string (concat "<" node-name) elem-string) (dom:map-node-map #'(lambda(attr) (let ((attr-name (dom:node-name attr)) (attr-value (dom:node-value attr))) - (push-string (concatenate 'string " " attr-name "=\"" - attr-value "\"") + (push-string (concat " " attr-name "=\"" attr-value "\"") elem-string))) attributes) (push-string ">" elem-string) (loop for child-node across child-nodes do (push-string (node-to-string child-node) elem-string)) - (push-string (concatenate 'string "</" node-name ">") elem-string)))) \ No newline at end of file + (push-string (concat "</" node-name ">") elem-string)))) \ No newline at end of file

1 0

[isidorus-cvs] r383 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 21 Dec '10

21 Dec '10

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 ()

1 0

[isidorus-cvs] r382 - trunk/src/base-tools
by Lukas Giessmann 21 Dec '10

21 Dec '10

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 ,@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)

1 0

[isidorus-cvs] r381 - in trunk/src: . TM-SPARQL
by Lukas Giessmann 20 Dec '10

20 Dec '10

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"

1 0

[isidorus-cvs] r380 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 20 Dec '10

20 Dec '10

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 ()

1 0

[isidorus-cvs] r379 - trunk/src/TM-SPARQL
by Lukas Giessmann 20 Dec '10

20 Dec '10

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)

1 0

[isidorus-cvs] r378 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 20 Dec '10

20 Dec '10

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 ()

1 0

[isidorus-cvs] r377 - trunk/src/TM-SPARQL
by Lukas Giessmann 19 Dec '10

19 Dec '10

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)

1 0

[isidorus-cvs] r376 - in trunk/src: . TM-SPARQL base-tools
by Lukas Giessmann 19 Dec '10

19 Dec '10

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"))

1 0

[isidorus-cvs] r375 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 19 Dec '10

19 Dec '10

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=)))))))))

1 0