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

[isidorus-cvs] r459 - in trunk/src: json/JTM unit_tests
by Lukas Giessmann 09 May '11

09 May '11

Author: lgiessmann Date: Mon May 9 05:28:16 2011 New Revision: 459 Log: JTM: added unit-tests for the function merge-topic-from-jtm-list => fixed a bug when referencing the topic that has to be merged Modified: trunk/src/json/JTM/jtm_importer.lisp trunk/src/unit_tests/jtm_test.lisp Modified: trunk/src/json/JTM/jtm_importer.lisp ============================================================================== --- trunk/src/json/JTM/jtm_importer.lisp (original) +++ trunk/src/json/JTM/jtm_importer.lisp Mon May 9 05:28:16 2011 @@ -78,7 +78,7 @@ (List parents) (Integer revision)) (unless parents - (error (make-condition 'JTM-error :message (format nil "From make-instance-of-association(): parents must contain at least one TopicMapC object, but is nil")))) + (error (make-condition 'missing-reference-error :message (format nil "From make-instance-of-association(): parents must contain at least one TopicMapC object, but is nil")))) (let ((t-top (get-item-by-psi *type-psi* :revision revision)) (i-top (get-item-by-psi *instance-psi* :revision revision)) (ti-top (get-item-by-psi *type-instance-psi* :revision revision))) @@ -119,7 +119,11 @@ (defun merge-topic-from-jtm-list(jtm-list parents &key (instance-of-p t) (revision *TM-REVISION*) prefixes) "Creates and returns a topic object from the passed jtm - list generated by json:decode-json-from-string." + list generated by json:decode-json-from-string. + Note that the merged topics are not added explicitly to the parent + topic maps, it is only needed for the instance-of-associations - + topics are added in the function import-topic-stubs-from-jtm-lists + to their topic map elements." (declare (List jtm-list prefixes parents) (Boolean instance-of-p) (Integer revision)) @@ -127,8 +131,9 @@ (get-item :SUBJECT--IDENTIFIERS jtm-list) (get-item :SUBJECT--LOCATORS jtm-list))) (top (when ids - (get-item-from-jtm-reference (first ids) :revision revision - :prefixes prefixes))) + (get-item-by-any-id + (compute-uri-from-jtm-identifier (first ids) prefixes) + :revision revision))) (instanceof (get-items-from-jtm-references (get-item :INSTANCE--OF jtm-list) :revision revision :prefixes prefixes)) Modified: trunk/src/unit_tests/jtm_test.lisp ============================================================================== --- trunk/src/unit_tests/jtm_test.lisp (original) +++ trunk/src/unit_tests/jtm_test.lisp Mon May 9 05:28:16 2011 @@ -41,7 +41,8 @@ :test-import-occurrences :test-import-names :test-make-instance-of-association - :test-import-topics)) + :test-import-topics + :test-merge-topics)) (in-package :jtm-test) @@ -1636,7 +1637,6 @@ #'jtm::import-name-from-jtm-list :revision 100))))) - (test test-make-instance-of-association "Tests the function make-instance-of-association." (with-fixture with-empty-db ("data_base") @@ -1704,7 +1704,7 @@ (and (eql (instance-of role :revision 0) it) (eql (player role :revision 0) top-2))) (roles assoc :revision 0)))) - (signals exceptions:JTM-error + (signals exceptions:missing-reference-error (jtm::make-instance-of-association top-1 top-3 nil :revision 100)) (delete-psi tt (elephant:get-instance-by-value 'PersistentIdc 'd:uri *type-psi*) @@ -1846,9 +1846,188 @@ nil :revision 200)))))) -;TODO: -; *merge-topics-from-jtm-lists -; *merge-topic-from-jtm-list + +(test test-merge-topics + "Tests the functions import-topic-stub-from-jtm-list, + and import-topic-stubs-from-jtm-lists." + (with-fixture with-empty-db ("data_base") + (let* ((prefixes (list (list :pref "xsd" :value *xsd-ns*) + (list :pref "pref_1" :value *xsd-ns*) + (list :pref "pref_2" :value "http://some.where/"))) + (j-top-1 "{\"version\":\"1.1\",\"prefixes\":{\"pref_1\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_2\":\"http:\\/\\/some.where\\/\"},\"subject_identifiers\":[\"[pref_2:psi-1]\",\"[pref_2:psi-2]\"],\"subject_locators\":[\"[pref_2:sl-2]\"],\"item_identifiers\":[\"[pref_2:ii-4]\"],\"instance_of\":[\"ii:[pref_2:ii-1]\"],\"item_type\":\"topic\",\"names\":[{\"item_identifiers\":null,\"value\":\"name-1\",\"type\":null,\"scope\":null,\"variants\":null,\"reifier\":null},{\"item_identifiers\":null,\"value\":\"name-2\",\"type\":null,\"scope\":[\"sl:[pref_2:sl-1]\"],\"variants\":[{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"var-1\",\"scope\":[\"ii:[pref_2:ii-1]\"],\"reifier\":null}],\"reifier\":null}],\"occurrences\":[{\"item_identifiers\":[\"[pref_2:ii-2]\"],\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"type\":\"sl:[pref_2:sl-1]\",\"value\":\"occ-1\",\"scope\":[\"si:[pref_2:psi-1]\"],\"reifier\":\"ii:[pref_2:ii-1]\"},{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#anyURI\",\"type\":\"si:[pref_2:psi-1]\",\"value\":\"http:\\/\\/any.uri\",\"scope\":null,\"reifier\":null}]}") + (j-top-2 "{\"version\":\"1.0\",\"subject_identifiers\":[\"http:\\/\\/some.where\\/psi-1\",\"http:\\/\\/some.where\\/psi-2\"],\"subject_locators\":[\"http:\\/\\/some.where\\/sl-2\"],\"item_identifiers\":[\"http:\\/\\/some.where\\/ii-4\"],\"item_type\":\"topic\",\"parent\":[\"ii:http:\\/\\/some.where\\/ii-3\"],\"names\":[{\"item_identifiers\":null,\"value\":\"name-1\",\"type\":null,\"scope\":null,\"variants\":null,\"reifier\":null},{\"item_identifiers\":null,\"value\":\"name-2\",\"type\":null,\"scope\":[\"sl:http:\\/\\/some.where\\/sl-1\"],\"variants\":[{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"var-1\",\"scope\":[\"ii:http:\\/\\/some.where\\/ii-1\"],\"reifier\":null}],\"reifier\":null}],\"occurrences\":[{\"item_identifiers\":[\"http:\\/\\/some.where\\/ii-2\"],\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"type\":\"sl:http:\\/\\/some.where\\/sl-1\",\"value\":\"occ-1\",\"scope\":[\"si:http:\\/\\/some.where\\/psi-1\"],\"reifier\":\"ii:http:\\/\\/some.where\\/ii-1\"},{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#anyURI\",\"type\":\"si:http:\\/\\/some.where\\/psi-1\",\"value\":\"http:\\/\\/any.uri\",\"scope\":null,\"reifier\":null}]}") + (j-top-3 "{\"subject_identifiers\":[\"http:\\/\\/some.where\\/tmsparql\\/author\"],\"subject_locators\":null,\"item_identifiers\":null,\"names\":null,\"occurrences\":null}") + (j-top-4 "{\"subject_identifiers\":null,\"subject_locators\":[\"http:\\/\\/some.where\\/sl-1\"],\"item_identifiers\":null,\"names\":null,\"occurrences\":null}") + (j-top-5 "{\"subject_identifiers\":null,\"subject_locators\":null,\"item_identifiers\":[\"http:\\/\\/some.where\\/ii-1\"],\"names\":null,\"occurrences\":null}") + (tm-1 (make-construct + 'TopicMapC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/tm-1")))) + (tm-2 (make-construct + 'TopicMapC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/tm-2")))) + (tops (jtm::import-topic-stubs-from-jtm-lists + (list (json:decode-json-from-string j-top-1) + (json:decode-json-from-string j-top-2) + (json:decode-json-from-string j-top-3) + (json:decode-json-from-string j-top-4) + (json:decode-json-from-string j-top-5)) + (list tm-1 tm-2) :revision 100 :prefixes prefixes))) + (is (= (length tops) 5)) + (is (= (length (remove-duplicates tops)) 4)) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 4)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 3)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 4)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 2)) + (is-false (elephant:get-instances-by-class 'NameC)) + (is-false (elephant:get-instances-by-class 'VariantC)) + (is-false (elephant:get-instances-by-class 'RoleC)) + (is-false (elephant:get-instances-by-class 'AssociationC)) + (is-false (elephant:get-instances-by-class 'OccurrenceC)) + (signals exceptions:missing-reference-error ;missing topics for + (jtm::merge-topic-from-jtm-list ;type-instance-associations + (json:decode-json-from-string j-top-1) + (list tm-1 tm-2) :revision 100 :prefixes prefixes)) + (make-construct 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri *type-psi*))) + (make-construct 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri *instance-psi*))) + (make-construct 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri *type-instance-psi*))) + (let ((top-1 (jtm::merge-topic-from-jtm-list + (json:decode-json-from-string j-top-1) + (list tm-1 tm-2) :revision 100 :prefixes prefixes)) + (top-2 (jtm::merge-topic-from-jtm-list + (json:decode-json-from-string j-top-2) + (list tm-1 tm-2) :revision 100 :prefixes prefixes))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 7)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 6)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 5)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 2)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 1)) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) + (is (eql top-1 top-2)) + (is (= (length (names top-1 :revision 0)) 2)) + (is-true (find-if #'(lambda(name) + (and (string= (charvalue name) "name-1") + (not (instance-of name :revision 0)) + (not (themes name :revision 0)) + (not (variants name :revision 0)) + (not (reifier name :revision 0)) + (not (item-identifiers name :revision 0)))) + (names top-1 :revision 0))) + (is-true + (find-if #'(lambda(name) + (and (string= (charvalue name) "name-2") + (not (instance-of name :revision 0)) + (= (length (themes name :revision 0)) 1) + (= (length (locators (first (themes name :revision 0)) + :revision 0)) 1) + (string= + (uri (first (locators (first (themes name :revision 0)) + :revision 0))) + "http://some.where/sl-1") + (= (length (variants name :revision 0)) 1) + (not (reifier name :revision 0)) + (not (item-identifiers name :revision 0)))) + (names top-1 :revision 0))) + (is-true + (find-if #'(lambda(occ) + (and (string= (charvalue occ) "occ-1") + (string= (datatype occ) *xml-string*) + (instance-of occ :revision 0) + (= (length (locators (instance-of occ :revision 0) + :revision 0)) 1) + (string= + (uri (first (locators (instance-of occ :revision 0) + :revision 0))) + "http://some.where/sl-1") + (= (length (themes occ :revision 0)) 1) + (= (length (psis (first (themes occ :revision 0)) + :revision 0)) 2) + (or (string= + (uri (first (psis (first (themes occ :revision 0)) + :revision 0))) + "http://some.where/psi-1") + (string= + (uri (second (psis (first (themes occ :revision 0)) + :revision 0))) + "http://some.where/psi-1")) + (reifier occ :revision 0) + (= (length (item-identifiers occ :revision 0)) 1) + (string= (uri (first (item-identifiers occ :revision 0))) + "http://some.where/ii-2"))) + (occurrences top-1 :revision 0))) + (is-true + (find-if #'(lambda(occ) + (and (string= (charvalue occ) "http://any.uri") + (string= (datatype occ) *xml-uri*) + (instance-of occ :revision 0) + (or (string= + (uri (first (psis (instance-of occ :revision 0) + :revision 0))) + "http://some.where/psi-1") + (string= + (uri (second (psis (instance-of occ :revision 0) + :revision 0))) + "http://some.where/psi-1")) + (not (themes occ :revision 0)) + (not (reifier occ :revision 0)) + (not (item-identifiers occ :revision 0)))) + (occurrences top-1 :revision 0)))) + (let ((tops (jtm::merge-topics-from-jtm-lists + (list (json:decode-json-from-string j-top-1) + (json:decode-json-from-string j-top-2) + (json:decode-json-from-string j-top-3) + (json:decode-json-from-string j-top-4) + (json:decode-json-from-string j-top-5)) + (list tm-1 tm-2) :revision 200 :prefixes prefixes))) + (is (= (length (remove-duplicates tops)) 4)) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 7)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 6)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 5)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 2)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 1)) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2))) + (signals exceptions:jtm-error + (jtm::merge-topic-from-jtm-list + (json:decode-json-from-string j-top-1) + (list tm-1 tm-2) :revision 200)) + (signals exceptions:jtm-error + (jtm::merge-topic-from-jtm-list + (json:decode-json-from-string j-top-1) + (list tm-1 tm-2) :revision 200 :prefixes prefixes :instance-of-p nil)) + (signals exceptions:missing-reference-error + (jtm::merge-topic-from-jtm-list + (json:decode-json-from-string j-top-1) + nil :revision 200 :prefixes prefixes)) + (signals exceptions:jtm-error + (jtm::merge-topics-from-jtm-lists + (list (json:decode-json-from-string j-top-1)) + (list tm-1 tm-2) :revision 200)) + (signals exceptions:jtm-error + (jtm::merge-topics-from-jtm-lists + (list (json:decode-json-from-string j-top-1)) + (list tm-1 tm-2) :revision 200 :prefixes prefixes :instance-of-p nil)) + (signals exceptions:missing-reference-error + (jtm::merge-topics-from-jtm-lists + (list (json:decode-json-from-string j-top-1)) + nil :revision 200 :prefixes prefixes))))) (defun run-jtm-tests()

1 0

[isidorus-cvs] r458 - trunk/src/unit_tests
by Lukas Giessmann 09 May '11

09 May '11

Author: lgiessmann Date: Mon May 9 03:59:00 2011 New Revision: 458 Log: JTM: added unit-tests fot the JTM-import of topic-stubs Modified: trunk/src/unit_tests/jtm_test.lisp Modified: trunk/src/unit_tests/jtm_test.lisp ============================================================================== --- trunk/src/unit_tests/jtm_test.lisp (original) +++ trunk/src/unit_tests/jtm_test.lisp Mon May 9 03:59:00 2011 @@ -40,7 +40,8 @@ :test-import-variants :test-import-occurrences :test-import-names - :test-make-instance-of-association)) + :test-make-instance-of-association + :test-import-topics)) (in-package :jtm-test) @@ -1553,8 +1554,8 @@ (test test-import-names - "Tests the functions import-name-from-jtm-string and - import-constructs-from-jtm-strings." + "Tests the functions import-name-from-jtm-list and + import-constructs-from-jtm-lists." (with-fixture with-empty-db ("data_base") (let* ((prefixes (list (list :pref "xsd" :value *xsd-ns*) (list :pref "pref_1" :value *xsd-ns*) @@ -1709,12 +1710,143 @@ tt (elephant:get-instance-by-value 'PersistentIdc 'd:uri *type-psi*) :revision 200) (signals exceptions:missing-reference-error - (jtm::make-instance-of-association top-1 top-3 (list tm) :revision 200)) - ))) + (jtm::make-instance-of-association top-1 top-3 (list tm) :revision 200))))) + + +(test test-import-topics + "Tests the functions import-topic-stub-from-jtm-list, + and import-topic-stubs-from-jtm-lists." + (with-fixture with-empty-db ("data_base") + (let* ((prefixes (list (list :pref "xsd" :value *xsd-ns*) + (list :pref "pref_1" :value *xsd-ns*) + (list :pref "pref_2" :value "http://some.where/"))) + (j-top-1 "{\"version\":\"1.1\",\"prefixes\":{\"pref_1\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_2\":\"http:\\/\\/some.where\\/\"},\"subject_identifiers\":[\"[pref_2:psi-1]\",\"[pref_2:psi-2]\"],\"subject_locators\":[\"[pref_2:sl-2]\"],\"item_identifiers\":[\"[pref_2:ii-4]\"],\"instance_of\":null,\"item_type\":\"topic\",\"names\":[{\"item_identifiers\":null,\"value\":\"name-1\",\"type\":null,\"scope\":null,\"variants\":null,\"reifier\":null},{\"item_identifiers\":null,\"value\":\"name-2\",\"type\":null,\"scope\":[\"sl:[pref_2:sl-1]\"],\"variants\":[{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"var-1\",\"scope\":[\"ii:[pref_2:ii-1]\"],\"reifier\":null}],\"reifier\":null}],\"occurrences\":[{\"item_identifiers\":[\"[pref_2:ii-2]\"],\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"type\":\"sl:[pref_2:sl-1]\",\"value\":\"occ-1\",\"scope\":[\"si:[pref_2:psi-1]\"],\"reifier\":\"ii:[pref_2:ii-1]\"},{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#anyURI\",\"type\":\"si:[pref_2:psi-1]\",\"value\":\"http:\\/\\/any.uri\",\"scope\":null,\"reifier\":null}]}") + (j-top-2 "{\"version\":\"1.0\",\"subject_identifiers\":[\"http:\\/\\/some.where\\/psi-1\",\"http:\\/\\/some.where\\/psi-2\"],\"subject_locators\":[\"http:\\/\\/some.where\\/sl-2\"],\"item_identifiers\":[\"http:\\/\\/some.where\\/ii-4\"],\"item_type\":\"topic\",\"parent\":[\"ii:http:\\/\\/some.where\\/ii-3\"],\"names\":[{\"item_identifiers\":null,\"value\":\"name-1\",\"type\":null,\"scope\":null,\"variants\":null,\"reifier\":null},{\"item_identifiers\":null,\"value\":\"name-2\",\"type\":null,\"scope\":[\"sl:http:\\/\\/some.where\\/sl-1\"],\"variants\":[{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"var-1\",\"scope\":[\"ii:http:\\/\\/some.where\\/ii-1\"],\"reifier\":null}],\"reifier\":null}],\"occurrences\":[{\"item_identifiers\":[\"http:\\/\\/some.where\\/ii-2\"],\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"type\":\"sl:http:\\/\\/some.where\\/sl-1\",\"value\":\"occ-1\",\"scope\":[\"si:http:\\/\\/some.where\\/psi-1\"],\"reifier\":\"ii:http:\\/\\/some.where\\/ii-1\"},{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#anyURI\",\"type\":\"si:http:\\/\\/some.where\\/psi-1\",\"value\":\"http:\\/\\/any.uri\",\"scope\":null,\"reifier\":null}]}") + (j-top-3 "{\"subject_identifiers\":[\"http:\\/\\/some.where\\/tmsparql\\/author\"],\"subject_locators\":null,\"item_identifiers\":null,\"names\":null,\"occurrences\":null}") + (j-top-4 "{\"subject_identifiers\":[\"http:\\/\\/some.where\\/tmsparql\\/first-name\"],\"subject_locators\":null,\"item_identifiers\":null,\"names\":null,\"occurrences\":null}") + (j-top-5 "{\"subject_identifiers\":null,\"subject_locators\":null,\"item_identifiers\":[\"http:\\/\\/some.where\\/ii\\/goethe-name-reifier\"],\"names\":null,\"occurrences\":null}") + (tm-1 (make-construct + 'TopicMapC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/tm-1")))) + (tm-2 (make-construct + 'TopicMapC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/tm-2"))))) + (is-false (elephant:get-instances-by-class 'd:TopicC)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2)) + (let ((top-1 (jtm::import-topic-stub-from-jtm-list + (json:decode-json-from-string j-top-1) + (list tm-1 tm-2) :revision 100 :prefixes prefixes))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 1)) + (is-false (elephant:get-instances-by-class 'NameC)) + (is-false (elephant:get-instances-by-class 'VariantC)) + (is-false (elephant:get-instances-by-class 'RoleC)) + (is-false (elephant:get-instances-by-class 'AssociationC)) + (is-false (elephant:get-instances-by-class 'OccurrenceC)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 2)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (is-false (set-exclusive-or (list "http://some.where/psi-1" + "http://some.where/psi-2") + (map 'list #'d:uri (psis top-1 :revision 0)) + :test #'string=)) + (is-false (set-exclusive-or + (list "http://some.where/sl-2") + (map 'list #'d:uri (locators top-1 :revision 0)) + :test #'string=)) + (is-false (set-exclusive-or + (list "http://some.where/ii-4") + (map 'list #'d:uri (item-identifiers top-1 :revision 0)) + :test #'string=)) + (is-true (find tm-1 (in-topicmaps top-1 :revision 0))) + (is-true (find tm-2 (in-topicmaps top-1 :revision 0)))) + (let ((top-2 (jtm::import-topic-stub-from-jtm-list + (json:decode-json-from-string j-top-2) + (list tm-1 tm-2) :revision 200))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 1)) + (is-false (elephant:get-instances-by-class 'NameC)) + (is-false (elephant:get-instances-by-class 'VariantC)) + (is-false (elephant:get-instances-by-class 'RoleC)) + (is-false (elephant:get-instances-by-class 'AssociationC)) + (is-false (elephant:get-instances-by-class 'OccurrenceC)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 2)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (is-false (set-exclusive-or (list "http://some.where/psi-1" + "http://some.where/psi-2") + (map 'list #'d:uri (psis top-2 :revision 200)) + :test #'string=)) + (is-false (set-exclusive-or + (list "http://some.where/sl-2") + (map 'list #'d:uri (locators top-2 :revision 200)) + :test #'string=)) + (is-false (set-exclusive-or + (list "http://some.where/ii-4") + (map 'list #'d:uri (item-identifiers top-2 :revision 200)) + :test #'string=)) + (is-true (find tm-1 (in-topicmaps top-2 :revision 200))) + (is-true (find tm-2 (in-topicmaps top-2 :revision 200)))) + (let ((tops-3-4-5 + (jtm::import-topic-stubs-from-jtm-lists + (list (json:decode-json-from-string j-top-3) + (json:decode-json-from-string j-top-4) + (json:decode-json-from-string j-top-5)) + (list tm-1 tm-2) :revision 200))) + (is (= (length tops-3-4-5) 3)) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 4)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 4)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 4)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (is-false (elephant:get-instances-by-class 'NameC)) + (is-false (elephant:get-instances-by-class 'VariantC)) + (is-false (elephant:get-instances-by-class 'RoleC)) + (is-false (elephant:get-instances-by-class 'AssociationC)) + (is-false (elephant:get-instances-by-class 'OccurrenceC)) + (is-true (find-if #'(lambda(top) + (and (= (length (psis top :revision 0)) 1) + (not (item-identifiers top :revision 0)) + (not (locators top :revision 0)) + (string= (uri (first (psis top :revision 0))) + "http://some.where/tmsparql/author"))) + tops-3-4-5)) + (is-true + (find-if #'(lambda(top) + (and (= (length (psis top :revision 0)) 1) + (not (item-identifiers top :revision 0)) + (not (locators top :revision 0)) + (string= (uri (first (psis top :revision 0))) + "http://some.where/tmsparql/first-name"))) + tops-3-4-5)) + (is-true + (find-if #'(lambda(top) + (and (= (length (item-identifiers top :revision 0)) 1) + (not (psis top :revision 0)) + (not (locators top :revision 0)) + (string= (uri (first (item-identifiers top :revision 0))) + "http://some.where/ii/goethe-name-reifier"))) + tops-3-4-5)) + (signals exceptions:jtm-error + (jtm::import-topic-stub-from-jtm-list + (json:decode-json-from-string j-top-1) + (list tm-1 tm-2) :revision 200)) + (signals exceptions:missing-reference-error + (jtm::import-topic-stub-from-jtm-list + (json:decode-json-from-string j-top-2) + nil :revision 200)) + (signals exceptions:jtm-error + (jtm::import-topic-stubs-from-jtm-lists + (list (json:decode-json-from-string j-top-1)) + (list tm-1 tm-2) :revision 200)) + (signals exceptions:missing-reference-error + (jtm::import-topic-stubs-from-jtm-lists + (list (json:decode-json-from-string j-top-2)) + nil :revision 200)))))) + ;TODO: -; *import-topic-stubs-from-jtm-lists -; *import-topic-stub-from-jtm-list ; *merge-topics-from-jtm-lists ; *merge-topic-from-jtm-list

1 0

[isidorus-cvs] r457 - in trunk/src: json/JTM unit_tests xml/xtm
by Lukas Giessmann 08 May '11

08 May '11

Author: lgiessmann Date: Sun May 8 12:53:59 2011 New Revision: 457 Log: JTM: added a unit-test for the function make-instance-of-association => if a new instance-of-association is created, all topic-types are added to the parent-topicmaps Modified: trunk/src/json/JTM/jtm_importer.lisp trunk/src/unit_tests/jtm_test.lisp trunk/src/xml/xtm/importer.lisp Modified: trunk/src/json/JTM/jtm_importer.lisp ============================================================================== --- trunk/src/json/JTM/jtm_importer.lisp (original) +++ trunk/src/json/JTM/jtm_importer.lisp Sun May 8 12:53:59 2011 @@ -77,9 +77,16 @@ (declare (TopicC instance-top type-top) (List parents) (Integer revision)) + (unless parents + (error (make-condition 'JTM-error :message (format nil "From make-instance-of-association(): parents must contain at least one TopicMapC object, but is nil")))) (let ((t-top (get-item-by-psi *type-psi* :revision revision)) (i-top (get-item-by-psi *instance-psi* :revision revision)) (ti-top (get-item-by-psi *type-instance-psi* :revision revision))) + (unless (and i-top t-top ti-top) + (let ((missing-topic (cond ((not t-top) *type-psi*) + ((not i-top) *instance-psi*) + (t *type-instance-psi*)))) + (error (make-condition 'missing-reference-error :message (format nil "From make-instance-of-association(): the core topics ~a, ~a, and ~a are necessary, but ~a cannot be found" *type-psi* *instance-psi* *type-instance-psi* missing-topic) :reference missing-topic)))) (let ((assoc (make-construct 'AssociationC :start-revision revision :instance-of ti-top :roles (list (list :start-revision revision @@ -89,6 +96,9 @@ :player type-top :instance-of t-top))))) (dolist (tm parents) + (add-to-tm tm i-top) + (add-to-tm tm t-top) + (add-to-tm tm ti-top) (add-to-tm tm assoc)) assoc))) Modified: trunk/src/unit_tests/jtm_test.lisp ============================================================================== --- trunk/src/unit_tests/jtm_test.lisp (original) +++ trunk/src/unit_tests/jtm_test.lisp Sun May 8 12:53:59 2011 @@ -39,7 +39,8 @@ :test-import-identifiers :test-import-variants :test-import-occurrences - :test-import-names)) + :test-import-names + :test-make-instance-of-association)) (in-package :jtm-test) @@ -1634,10 +1635,86 @@ #'jtm::import-name-from-jtm-list :revision 100))))) + +(test test-make-instance-of-association + "Tests the function make-instance-of-association." + (with-fixture with-empty-db ("data_base") + (let* ((tt (make-construct 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri *type-psi*)))) + (it (make-construct 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri *instance-psi*)))) + (tit (make-construct 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri *type-instance-psi*)))) + (top-1 (make-construct + 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri "http://some.where/psi-1")))) + (top-2 (make-construct + 'TopicC :start-revision 100 + :locators + (list (make-construct 'SubjectLocatorC + :uri "http://some.where/sl-1")))) + (top-3 (make-construct + 'TopicC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/ii-1")))) + (tm (make-construct + 'TopicMapC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/tm-ii"))))) + (jtm::make-instance-of-association top-1 top-2 (list tm) :revision 100) + (is (= (length (player-in-roles top-1 :revision 0)) 1)) + (is (eql (instance-of (first (player-in-roles top-1 :revision 0)) :revision 0) + it)) + (let ((assoc (parent (first (player-in-roles top-1 :revision 0)) :revision 0))) + (is-true assoc) + (is (= (length (roles assoc :revision 0)) 2)) + (is (eql (instance-of assoc :revision 0) tit)) + (is-true (find tm (in-topicmaps assoc :revision 0))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role :revision 0) tt) + (eql (player role :revision 0) top-2))) + (roles assoc :revision 0)))) + (is (= (length (player-in-roles top-2 :revision 0)) 1)) + (is-true (find tm (in-topicmaps tt :revision 0))) + (is-false (find tm (in-topicmaps tt :revision 50))) + (is-true (find tm (in-topicmaps it :revision 0))) + (is-true (find tm (in-topicmaps tit :revision 0))) + (jtm::make-instance-of-association top-2 top-3 (list tm) :revision 100) + (is (= (length (player-in-roles top-2 :revision 0)) 2)) + (is (= (length (player-in-roles top-3 :revision 0)) 1)) + (is (eql (instance-of (first (player-in-roles top-3 :revision 0)) :revision 0) + tt)) + (let ((assoc (parent (first (player-in-roles top-3 :revision 0)) :revision 0))) + (is-true assoc) + (is (= (length (roles assoc :revision 0)) 2)) + (is (eql (instance-of assoc :revision 0) tit)) + (is-true (find tm (in-topicmaps assoc :revision 0))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role :revision 0) it) + (eql (player role :revision 0) top-2))) + (roles assoc :revision 0)))) + (signals exceptions:JTM-error + (jtm::make-instance-of-association top-1 top-3 nil :revision 100)) + (delete-psi + tt (elephant:get-instance-by-value 'PersistentIdc 'd:uri *type-psi*) + :revision 200) + (signals exceptions:missing-reference-error + (jtm::make-instance-of-association top-1 top-3 (list tm) :revision 200)) + ))) + ;TODO: ; *import-topic-stubs-from-jtm-lists ; *import-topic-stub-from-jtm-list -; *make-instance-of-association ; *merge-topics-from-jtm-lists ; *merge-topic-from-jtm-list Modified: trunk/src/xml/xtm/importer.lisp ============================================================================== --- trunk/src/xml/xtm/importer.lisp (original) +++ trunk/src/xml/xtm/importer.lisp Sun May 8 12:53:59 2011 @@ -130,6 +130,7 @@ (from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm"))) (add-to-tm tm top))))))) + ;TODO: replace the two importers with this macro (defmacro importer-mac (get-topic-elems get-association-elems

1 0

[isidorus-cvs] r456 - in trunk/src: json/JTM unit_tests
by Lukas Giessmann 07 May '11

07 May '11

Author: lgiessmann Date: Sat May 7 18:02:56 2011 New Revision: 456 Log: JTM: added functions that allow the import of a single topicstub, topic an array of topicstubs and topics Modified: trunk/src/json/JTM/jtm_importer.lisp trunk/src/unit_tests/jtm_test.lisp Modified: trunk/src/json/JTM/jtm_importer.lisp ============================================================================== --- trunk/src/json/JTM/jtm_importer.lisp (original) +++ trunk/src/json/JTM/jtm_importer.lisp Sat May 7 18:02:56 2011 @@ -21,6 +21,130 @@ (rest (find item-keyword jtm-list :key #'first))) +(defun import-topic-stubs-from-jtm-lists (jtm-lists parents &key + (revision *TM-REVISION*) prefixes) + "Creates and returns a list of topics. + Note only the topic identifiers are imported and set in this function, + entire topics are imported in merge-topics-from-jtm-lists." + (declare (List jtm-lists parents prefixes) + (Integer revision)) + (map 'list #'(lambda(jtm-list) + (import-topic-stub-from-jtm-list + jtm-list parents :revision revision :prefixes prefixes)) + jtm-lists)) + + +(defun import-topic-stub-from-jtm-list(jtm-list parents &key + (revision *TM-REVISION*) prefixes) + "Creates and returns a topic object from the passed jtm + list generated by json:decode-json-from-string. + Note this function only sets the topic's identifiers." + (declare (List jtm-list parents prefixes) + (Integer revision)) + (let* ((t-iis (import-identifiers-from-jtm-strings + (get-item :ITEM--IDENTIFIERS jtm-list) + :prefixes prefixes)) + (t-psis (import-identifiers-from-jtm-strings + (get-item :SUBJECT--IDENTIFIERS jtm-list) + :prefixes prefixes :identifier-type-symbol 'd:PersistentIdC)) + (t-sls (import-identifiers-from-jtm-strings + (get-item :SUBJECT--LOCATORS jtm-list) + :prefixes prefixes :identifier-type-symbol 'd:SubjectLocatorC)) + (parent-references (get-item :PARENT jtm-list)) + (local-parents + (if parents + parents + (when parent-references + (get-items-from-jtm-references + parent-references :revision revision :prefixes prefixes))))) + (unless local-parents + (error (make-condition 'JTM-error :message (format nil "From import-topic-from-jtm-string(): the JTM topic ~a must have at least one parent set in its members." jtm-list)))) + (unless (append t-iis t-sls t-psis) + (error (make-condition 'JTM-error :message (format nil "From import-topic-from-jtm-string(): the JTM topic ~a must have at least one identifier set in its members." jtm-list)))) + (let* ((top (make-construct 'TopicC :start-revision revision + :psis t-psis + :item-identifiers t-iis + :locators t-sls))) + (dolist (tm local-parents) + (add-to-tm tm top)) + top))) + + +(defun make-instance-of-association (instance-top type-top parents &key + (revision *TM-REVISION*)) + "Creates and returns a type-instance-association for the passed + instance and type topics." + (declare (TopicC instance-top type-top) + (List parents) + (Integer revision)) + (let ((t-top (get-item-by-psi *type-psi* :revision revision)) + (i-top (get-item-by-psi *instance-psi* :revision revision)) + (ti-top (get-item-by-psi *type-instance-psi* :revision revision))) + (let ((assoc (make-construct 'AssociationC :start-revision revision + :instance-of ti-top + :roles (list (list :start-revision revision + :player instance-top + :instance-of i-top) + (list :start-revision revision + :player type-top + :instance-of t-top))))) + (dolist (tm parents) + (add-to-tm tm assoc)) + assoc))) + + +(defun merge-topics-from-jtm-lists (jtm-lists parents &key (instance-of-p t) + (revision *TM-REVISION*) prefixes) + "Creates and returns a list of topics." + (declare (List jtm-lists parents prefixes) + (Boolean instance-of-p) + (Integer revision)) + (map 'list #'(lambda(jtm-list) + (merge-topic-from-jtm-list + jtm-list parents :revision revision :prefixes prefixes + :instance-of-p instance-of-p)) + jtm-lists)) + + +(defun merge-topic-from-jtm-list(jtm-list parents &key (instance-of-p t) + (revision *TM-REVISION*) prefixes) + "Creates and returns a topic object from the passed jtm + list generated by json:decode-json-from-string." + (declare (List jtm-list prefixes parents) + (Boolean instance-of-p) + (Integer revision)) + (let* ((ids (append (get-item :ITEM--IDENTIFIERS jtm-list) + (get-item :SUBJECT--IDENTIFIERS jtm-list) + (get-item :SUBJECT--LOCATORS jtm-list))) + (top (when ids + (get-item-from-jtm-reference (first ids) :revision revision + :prefixes prefixes))) + (instanceof (get-items-from-jtm-references + (get-item :INSTANCE--OF jtm-list) :revision revision + :prefixes prefixes)) + (top-names (import-characteristics-from-jtm-lists + (get-item :NAMES jtm-list) top + #'import-name-from-jtm-list :revision revision + :prefixes prefixes)) + (top-occs (import-characteristics-from-jtm-lists + (get-item :OCCURRENCES jtm-list) top + #'import-occurrence-from-jtm-list :revision revision + :prefixes prefixes))) + (unless ids + (error (make-condition 'JTM-error :message (format nil "From merge-topic-from-jtm-list(): the passed topic has to own at least one identifier: ~a" jtm-list)))) + (unless top + (error (make-condition 'JTM-error :message (format nil "From merge-topic-from-jtm-list(): cannot find a topic that matches the corresponding JTM-list: ~a" jtm-list)))) + (when (and (not instance-of-p) instanceof) + (error (make-condition 'JTM-error :message (format nil "From merge-topic-from-jtm-list(): the JTM-topic has an instance_of member set, but JTM version 1.0 does not allow an intance_of member within a topic object: ~a" jtm-list)))) + (dolist (type-top instanceof) + (make-instance-of-association top type-top parents :revision revision)) + (dolist (name top-names) + (add-name top name :revision revision)) + (dolist (occ top-occs) + (add-occurrence top occ :revision revision)) + top)) + + (defun import-name-from-jtm-list (jtm-list parent &key (revision *TM-REVISION*) prefixes) "Creates and returns a name object from the passed jtm @@ -59,9 +183,9 @@ :reifier (when reifier (get-item-from-jtm-reference reifier :revision revision :prefixes prefixes))))) - (import-constructs-from-jtm-lists name-variants name - #'import-variant-from-jtm-list - :revision revision :prefixes prefixes) + (import-characteristics-from-jtm-lists name-variants name + #'import-variant-from-jtm-list + :revision revision :prefixes prefixes) name))) @@ -105,8 +229,8 @@ reifier :revision revision :prefixes prefixes))))) -(defun import-constructs-from-jtm-lists(jtm-lists parent next-fun &key - (revision *TM-REVISION*) prefixes) +(defun import-characteristics-from-jtm-lists(jtm-lists parent next-fun &key + (revision *TM-REVISION*) prefixes) "Creates and returns a list of TM-Constructs returned by next-fun." (declare (List jtm-lists prefixes) (Integer revision) Modified: trunk/src/unit_tests/jtm_test.lisp ============================================================================== --- trunk/src/unit_tests/jtm_test.lisp (original) +++ trunk/src/unit_tests/jtm_test.lisp Sat May 7 18:02:56 2011 @@ -1634,6 +1634,14 @@ #'jtm::import-name-from-jtm-list :revision 100))))) +;TODO: +; *import-topic-stubs-from-jtm-lists +; *import-topic-stub-from-jtm-list +; *make-instance-of-association +; *merge-topics-from-jtm-lists +; *merge-topic-from-jtm-list + + (defun run-jtm-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'jtm-tests)) \ No newline at end of file

1 0

[isidorus-cvs] r455 - in trunk/src: json/JTM model unit_tests
by Lukas Giessmann 06 May '11

06 May '11

Author: lgiessmann Date: Fri May 6 19:02:35 2011 New Revision: 455 Log: JTM: added unit-tests for functions that are responsible for importing jtm-variants, jtm-names, and jtm-occurrences => fixed some bugs Modified: trunk/src/json/JTM/jtm_importer.lisp trunk/src/model/datamodel.lisp trunk/src/unit_tests/jtm_test.lisp Modified: trunk/src/json/JTM/jtm_importer.lisp ============================================================================== --- trunk/src/json/JTM/jtm_importer.lisp (original) +++ trunk/src/json/JTM/jtm_importer.lisp Fri May 6 19:02:35 2011 @@ -32,7 +32,7 @@ (get-item :ITEM--IDENTIFIERS jtm-list) :prefixes prefixes)) (scope (get-item :SCOPE jtm-list)) - (type (get-item :SCOPE jtm-list)) + (type (get-item :TYPE jtm-list)) (value (get-item :VALUE jtm-list)) (name-variants (get-item :VARIANTS jtm-list)) (reifier (get-item :REIFIER jtm-list)) @@ -43,20 +43,19 @@ (when parent-references (get-items-from-jtm-references parent-references :revision revision :prefixes prefixes))))) - (unless local-parent - (error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-string(): the JTM occurrence ~a must have a parent set in its members." jtm-list)))) - (unless type - (error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-string(): the JTM occurrence ~a must have a type set in its members." jtm-list)))) + (when (/= (length local-parent) 1) + (error (make-condition 'JTM-error :message (format nil "From import-name-from-jtm-string(): the JTM name ~a must have exactly one parent set in its members." jtm-list)))) (let ((name (make-construct 'NameC :start-revision revision :item-identifiers iis - :value (if value value "") + :charvalue value :themes (get-items-from-jtm-references scope :revision revision :prefixes prefixes) - :instance-of (get-item-from-jtm-reference - type :revision revision :prefixes prefixes) - :parent local-parent + :instance-of (when type + (get-item-from-jtm-reference + type :revision revision :prefixes prefixes)) + :parent (first local-parent) :reifier (when reifier (get-item-from-jtm-reference reifier :revision revision :prefixes prefixes))))) @@ -72,13 +71,13 @@ list generated by json:decode-json-from-string." (declare (List jtm-list prefixes) (Integer revision) - (type (or Null OccurrenceC) parent)) + (type (or Null TopicC) parent)) (let* ((iis (import-identifiers-from-jtm-strings (get-item :ITEM--IDENTIFIERS jtm-list) :prefixes prefixes)) (datatype (get-item :DATATYPE jtm-list)) (scope (get-item :SCOPE jtm-list)) - (type (get-item :SCOPE jtm-list)) + (type (get-item :TYPE jtm-list)) (value (get-item :VALUE jtm-list)) (reifier (get-item :REIFIER jtm-list)) (parent-references (get-item :PARENT jtm-list)) @@ -88,19 +87,19 @@ (when parent-references (get-items-from-jtm-references parent-references :revision revision :prefixes prefixes))))) - (unless local-parent + (when (/= (length local-parent) 1) (error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-string(): the JTM occurrence ~a must have a parent set in its members." jtm-list)))) (unless type (error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-string(): the JTM occurrence ~a must have a type set in its members." jtm-list)))) (make-construct 'OccurrenceC :start-revision revision :item-identifiers iis :datatype (if datatype datatype *xml-string*) - :value (if value value "") + :charvalue value :themes (get-items-from-jtm-references scope :revision revision :prefixes prefixes) :instance-of (get-item-from-jtm-reference type :revision revision :prefixes prefixes) - :parent local-parent + :parent (first local-parent) :reifier (when reifier (get-item-from-jtm-reference reifier :revision revision :prefixes prefixes))))) @@ -111,7 +110,7 @@ "Creates and returns a list of TM-Constructs returned by next-fun." (declare (List jtm-lists prefixes) (Integer revision) - (type (or Null NameC) parent) + (type (or Null ReifiableConstructC) parent) (Function next-fun)) (map 'list #'(lambda(jtm-list) (apply next-fun (list jtm-list parent :revision revision @@ -140,22 +139,22 @@ (when parent-references (get-items-from-jtm-references parent-references :revision revision :prefixes prefixes))))) - (unless local-parent - (error (make-condition 'JTM-error :message (format nil "From import-variant-from-jtm-string(): the JTM variant ~a must have a parent set in its members." jtm-list)))) + (when (/= (length local-parent) 1) + (error (make-condition 'JTM-error :message (format nil "From import-variant-from-jtm-string(): the JTM variant ~a must have exactly one parent set in its members." jtm-list)))) (make-construct 'VariantC :start-revision revision :item-identifiers iis :datatype (if datatype datatype *xml-string*) - :value (if value value "") + :charvalue value :themes (get-items-from-jtm-references scope :revision revision :prefixes prefixes) - :parent local-parent + :parent (first local-parent) :reifier (when reifier (get-item-from-jtm-reference reifier :revision revision :prefixes prefixes))))) (defun import-identifiers-from-jtm-strings - (jtm-strings &key (identifier-type-symbol 'ItemIdentifeirC) prefixes) + (jtm-strings &key (identifier-type-symbol 'ItemIdentifierC) prefixes) "Creates and returns a list of identifiers specified by jtm-strings and identifier-type-symbol." (declare (List jtm-strings) @@ -163,11 +162,13 @@ (List prefixes)) (map 'list #'(lambda(jtm-string) (import-identifier-from-jtm-string - jtm-string identifier-type-symbol :prefixes prefixes)) + jtm-string :prefixes prefixes + :identifier-type-symbol identifier-type-symbol)) jtm-strings)) -(defun import-identifier-from-jtm-string(jtm-string identifier-type-symbol - &key prefixes) + +(defun import-identifier-from-jtm-string + (jtm-string &key (identifier-type-symbol 'ItemIdentifierC) prefixes) "Creates and returns an identifier of the type specified by identifier-type-symbol." (declare (String jtm-string) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri May 6 19:02:35 2011 @@ -2224,15 +2224,19 @@ :revision revision))))) ;no revision need to be checked, since the revision ;is implicitely checked by the function identified-construct - (if (and result - (let ((parent-elem - (when (or (typep result 'CharacteristicC) - (typep result 'RoleC)) - (parent result :revision revision)))) - (find-item-by-revision result revision parent-elem))) + (if result result (when error-if-nil (error (make-object-not-found-condition "No such item is bound to the given identifier uri.")))))) +;(if (and result +;(let ((parent-elem +;(when (or (typep result 'CharacteristicC) +;(typep result 'RoleC)) +;(parent result :revision revision)))) +;(find-item-by-revision result revision parent-elem))) +;result +;(when error-if-nil +;(error (make-object-not-found-condition "No such item is bound to the given identifier uri.")))))) (defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*) Modified: trunk/src/unit_tests/jtm_test.lisp ============================================================================== --- trunk/src/unit_tests/jtm_test.lisp (original) +++ trunk/src/unit_tests/jtm_test.lisp Fri May 6 19:02:35 2011 @@ -34,7 +34,12 @@ :test-export-to-jtm-fragment :test-export-as-jtm :test-import-jtm-references-1 - :test-import-jtm-references-2)) + :test-import-jtm-references-2 + :test-get-item + :test-import-identifiers + :test-import-variants + :test-import-occurrences + :test-import-names)) (in-package :jtm-test) @@ -1298,17 +1303,335 @@ (is (eql (elt refs (+ idx 4)) assoc-1))))))) +(test test-get-item + "Tests the function get-item." + (let* ((jtm-variant "{\"version\":\"1.1\",\"prefixes\":{\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_1\":\"http:\\/\\/some.where\\/\"},\"item_identifiers\":[\"http://some.where/ii-1\",\"[pref_1:ii-2]\"],\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"var-1\",\"item_type\":\"variant\",\"parent\":[\"ii:[pref_1:ii-1]\"],\"scope\":[\"si:[pref_1:psi-1]\"],\"reifier\":null}") + (jtm-lst (json:decode-json-from-string jtm-variant))) + (is (string= (jtm::get-item :VERSION jtm-lst) "1.1")) + (is-false (set-exclusive-or (jtm::get-item :ITEM--IDENTIFIERS jtm-lst) + (list "http://some.where/ii-1" + "[pref_1:ii-2]") :test #'string=)) + (is (eql (first (first (jtm::get-item :PREFIXES jtm-lst))) :XSD)) + (is (string= (rest (first (jtm::get-item :PREFIXES jtm-lst))) + "http://www.w3.org/2001/XMLSchema#")) + (is (eql (first (second (jtm::get-item :PREFIXES jtm-lst))) :PREF--1)) + (is (string= (rest (second (jtm::get-item :PREFIXES jtm-lst))) + "http://some.where/")))) + + +(test test-import-identifiers + "Tests the functions import-identifier-from-jtm-string and + import-identifiers-from-jtm-strings." + (with-fixture with-empty-db ("data_base") + (let* ((prefixes (list (list :pref "pref_1" :value "http://pref.org/") + (list :pref "pref_2" :value "http://pref.org#") + (list :pref "pref_3" :value "http://pref.org/app/"))) + (j-ii-1 "http://pref.org/ii-1") + (j-ii-2 "[pref_1:ii-2]") + (j-sl-1 "[pref_2:sl-1]") + (j-sl-2 "[pref_3:app_2/sl-2]") + (j-psi-1 "[pref_3:psi-1]") + (j-psi-2 "http://pref.org/psi-2") + (ii-1 (jtm::import-identifier-from-jtm-string j-ii-1 :prefixes prefixes)) + (sl-1 (jtm::import-identifier-from-jtm-string + j-sl-1 :prefixes prefixes :identifier-type-symbol 'SubjectLocatorC)) + (psi-1 (jtm::import-identifier-from-jtm-string + j-psi-1 :prefixes prefixes :identifier-type-symbol 'PersistentIdC)) + (psi-2 (jtm::import-identifier-from-jtm-string + j-psi-2 :prefixes prefixes :identifier-type-symbol 'PersistentIdC)) + (psis (jtm::import-identifiers-from-jtm-strings + (list j-psi-1 j-psi-2) :prefixes prefixes + :identifier-type-symbol 'PersistentIdC)) + (iis (jtm::import-identifiers-from-jtm-strings (list j-ii-1 j-ii-2) + :prefixes prefixes)) + (ii-2 (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://pref.org/ii-2")) + (sls (jtm::import-identifiers-from-jtm-strings + (list j-sl-1 j-sl-2) :prefixes prefixes + :identifier-type-symbol 'SubjectLocatorC)) + (sl-2 (elephant:get-instance-by-value + 'd:SubjectLocatorC 'd:uri "http://pref.org/app/app_2/sl-2"))) + (signals exceptions:JTM-error + (jtm::import-identifier-from-jtm-string j-ii-2)) + (signals exceptions:duplicate-identifier-error + (jtm::import-identifier-from-jtm-string + j-ii-1 :identifier-type-symbol 'PersistentIdC)) + (signals exceptions:JTM-error + (jtm::import-identifiers-from-jtm-strings (list j-ii-2))) + (signals exceptions:duplicate-identifier-error + (jtm::import-identifiers-from-jtm-strings + (list j-ii-1) :identifier-type-symbol 'PersistentIdC)) + (is (eql (elephant:get-instance-by-value 'd:ItemIdentifierC 'd:uri j-ii-1) + ii-1)) + (is (find ii-2 iis)) + (is (eql (elephant:get-instance-by-value + 'd:SubjectLocatorC 'd:uri "http://pref.org#sl-1") + sl-1)) + (is (find sl-2 sls)) + (is (eql (elephant:get-instance-by-value + 'd:PersistentIdC 'd:uri "http://pref.org/app/psi-1") + psi-1)) + (is (eql (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri j-psi-2) + psi-2)) + (is-false (set-exclusive-or psis (list psi-1 psi-2))) + (is-false (set-exclusive-or iis (list ii-1 ii-2))) + (is-false (set-exclusive-or sls (list sl-1 sl-2)))))) + + +(test test-import-variants + "Tests the functions import-variant-from-jtm-string and + import-constructs-from-jtm-strings." + (with-fixture with-empty-db ("data_base") + (let* ((prefixes (list (list :pref "xsd" :value *xsd-ns*) + (list :pref "pref_1" :value "http://some.where/"))) + (jtm-var-1 (concat "{\"version\":\"1.1\",\"prefixes\":{\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_1\":\"http:\\/\\/some.where\\/\"},\"item_identifiers\":null,\"datatype\":" (json:encode-json-to-string *xml-string*) ",\"value\":\"var-1\",\"item_type\":\"variant\",\"parent\":[\"ii:[pref_1:ii-1]\"],\"scope\":[\"si:[pref_1:psi-1]\"],\"reifier\":null}")) + (jtm-var-2 (concat "{\"version\":\"1.0\",\"item_identifiers\":[\"http:\\/\\/some.where\\/ii-3\"],\"datatype\":" (json:encode-json-to-string *xml-uri*) ",\"value\":\"http:\\/\\/any.uri\",\"item_type\":\"variant\",\"scope\":[\"sl:http:\\/\\/some.where\\/sl-1\"],\"reifier\":\"ii:http:\\/\\/some.where\\/ii-2\"}")) + (jtm-var-3 (concat "{\"version\":\"1.1\",\"prefixes\":{\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_1\":\"http:\\/\\/some.where\\/\"},\"item_identifiers\":null,\"datatype\":" (json:encode-json-to-string *xml-string*) ",\"value\":\"var-1\",\"item_type\":\"variant\",\"parent\":[\"ii:[pref_1:ii-10]\"],\"scope\":[\"si:[pref_1:psi-1]\"],\"reifier\":null}")) + (name-1 (make-construct + 'NameC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/ii-1")))) + (scope-1 (make-construct + 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri "http://some.where/psi-1")))) + (var-1 (jtm::import-variant-from-jtm-list + (json:decode-json-from-string jtm-var-1) nil :revision 100 + :prefixes prefixes)) + (scope-2 (make-construct + 'TopicC :start-revision 100 + :locators + (list (make-construct 'SubjectLocatorC + :uri "http://some.where/sl-1")))) + (reifier-2 (make-construct + 'TopicC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/ii-2")))) + (var-2 (jtm::import-variant-from-jtm-list + (json:decode-json-from-string jtm-var-2) name-1 :revision 100 + :prefixes prefixes)) + (vars (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-var-1) + (json:decode-json-from-string jtm-var-2)) name-1 + #'jtm::import-variant-from-jtm-list :revision 100 + :prefixes prefixes))) + (is-true (d:find-item-by-revision var-1 100 name-1)) + (is-false (d:find-item-by-revision var-1 50 name-1)) + (is (eql (parent var-1 :revision 0) name-1)) + (is (eql (parent var-2 :revision 0) name-1)) + (is (string= (datatype var-1) *xml-string*)) + (is (string= (datatype var-2) *xml-uri*)) + (is (string= (charvalue var-1) "var-1")) + (is (string= (charvalue var-2) "http://any.uri")) + (is-false (d:item-identifiers var-1 :revision 0)) + (is-false (set-exclusive-or + (map 'list #'d:uri (d:item-identifiers var-2 :revision 0)) + (list "http://some.where/ii-3") :test #'string=)) + (is-false (reifier var-1 :revision 0)) + (is (eql (reifier var-2 :revision 0) reifier-2)) + (is-false (set-exclusive-or (themes var-1 :revision 0) (list scope-1))) + (is-false (set-exclusive-or (themes var-2 :revision 0) (list scope-2))) + (is-false (set-exclusive-or vars (list var-1 var-2))) + (signals exceptions:missing-reference-error + (jtm::import-variant-from-jtm-list + (json:decode-json-from-string jtm-var-3) nil :revision 100 + :prefixes prefixes)) + (signals exceptions:JTM-error + (jtm::import-variant-from-jtm-list + (json:decode-json-from-string jtm-var-1) name-1 :revision 100)) + (signals exceptions:JTM-error + (jtm::import-variant-from-jtm-list + (json:decode-json-from-string jtm-var-2) nil :revision 100)) + (signals exceptions:missing-reference-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-var-3)) nil + #'jtm::import-variant-from-jtm-list :revision 100 + :prefixes prefixes)) + (signals exceptions:JTM-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-var-1)) name-1 + #'jtm::import-variant-from-jtm-list :revision 100)) + (signals exceptions:JTM-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-var-2)) nil + #'jtm::import-variant-from-jtm-list :revision 100))))) -;TODO: *get-item -; *import-identifier-from-jtm-string -; *import-identifiers-from-jtm-strings -; *import-variant-from-jtm-list -; *import-variants-from-jtm-lists -; *import-occurrence-from-jtm-list -; *import-occurrences-from-jtm-lists -; *import-name-from-jtm-list -; *import-names-from-jtm-lists +(test test-import-occurrences + "Tests the functions import-occurrence-from-jtm-string and + import-constructs-from-jtm-strings." + (with-fixture with-empty-db ("data_base") + (let* ((prefixes (list (list :pref "xsd" :value *xsd-ns*) + (list :pref "pref_1" :value "http://some.where/"))) + (jtm-occ-1 (concat "{\"version\":\"1.1\",\"prefixes\":{\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_1\":\"http:\\/\\/some.where\\/\"},\"item_identifiers\":[\"[pref_1:ii-2]\"],\"datatype\":" (json:encode-json-to-string *xml-string* ) ",\"type\":\"sl:[pref_1:sl-1]\",\"value\":\"occ-1\",\"item_type\":\"occurrence\",\"parent\":[\"si:[pref_1:psi-1]\"],\"scope\":[\"si:[pref_1:psi-1]\"],\"reifier\":\"ii:[pref_1:ii-1]\"}")) + (jtm-occ-2 (concat "{\"version\":\"1.0\",\"item_identifiers\":null,\"datatype\":" (json:encode-json-to-string *xml-uri* ) ",\"type\":\"si:http:\\/\\/some.where\\/psi-1\",\"value\":\"http:\\/\\/any.uri\",\"item_type\":\"occurrence\",\"scope\":null,\"reifier\":null}")) + (jtm-occ-3 (concat "{\"version\":\"1.1\",\"prefixes\":{\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_1\":\"http:\\/\\/some.where\\/\"},\"item_identifiers\":[\"[pref_1:ii-2]\"],\"datatype\":" (json:encode-json-to-string *xml-string* ) ",\"type\":\"sl:[pref_1:sl-1]\",\"value\":\"occ-1\",\"item_type\":\"occurrence\",\"parent\":[\"si:[pref_1:psi-6]\"],\"scope\":[\"si:[pref_1:psi-1]\"],\"reifier\":\"ii:[pref_1:ii-1]\"}")) + (jtm-occ-4 (concat "{\"version\":\"1.0\",\"item_identifiers\":null,\"datatype\":" (json:encode-json-to-string *xml-uri* ) ",\"type\":null,\"value\":\"http:\\/\\/any.uri\",\"item_type\":\"occurrence\",\"scope\":null,\"reifier\":null}")) + (jtm-occ-5 (concat "{\"version\":\"1.0\",\"item_identifiers\":null,\"datatype\":" (json:encode-json-to-string *xml-uri* ) ",\"type\":\"si:http://any-uri/psi-10\",\"value\":\"http:\\/\\/any.uri\",\"item_type\":\"occurrence\",\"scope\":null,\"reifier\":null}")) + (type-1 (make-construct + 'TopicC :start-revision 0 + :locators + (list (make-construct 'SubjectLocatorC + :uri "http://some.where/sl-1")))) + (scope-1 (make-construct + 'TopicC :start-revision 0 + :psis + (list (make-construct 'PersistentIdC + :uri "http://some.where/psi-1")))) + (reifier-1 (make-construct + 'TopicC :start-revision 0 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/ii-1")))) + (parent-1 scope-1) + (type-2 scope-1) + (occ-1 (jtm::import-occurrence-from-jtm-list + (json:decode-json-from-string jtm-occ-1) nil :revision 100 + :prefixes prefixes)) + (occ-2 (jtm::import-occurrence-from-jtm-list + (json:decode-json-from-string jtm-occ-2) parent-1 :revision 100 + :prefixes prefixes)) + (occs (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-occ-1) + (json:decode-json-from-string jtm-occ-2)) parent-1 + #'jtm::import-occurrence-from-jtm-list :revision 100 + :prefixes prefixes))) + (is-true (d:find-item-by-revision occ-1 100 parent-1)) + (is-false (d:find-item-by-revision occ-1 50 parent-1)) + (is (eql (parent occ-1 :revision 0) parent-1)) + (is (eql (parent occ-2 :revision 0) parent-1)) + (is (string= (datatype occ-1) *xml-string*)) + (is (string= (datatype occ-2) *xml-uri*)) + (is (string= (charvalue occ-1) "occ-1")) + (is (string= (charvalue occ-2) "http://any.uri")) + (is-false (set-exclusive-or + (map 'list #'d:uri (d:item-identifiers occ-1 :revision 0)) + (list "http://some.where/ii-2") :test #'string=)) + (is-false (d:item-identifiers occ-2 :revision 0)) + (is (eql (reifier occ-1 :revision 0) reifier-1)) + (is-false (reifier occ-2 :revision 0)) + (is-false (set-exclusive-or (themes occ-1 :revision 0) (list scope-1))) + (is-false (themes occ-2 :revision 0)) + (is (eql (instance-of occ-1 :revision 0) type-1)) + (is (eql (instance-of occ-2 :revision 0) type-2)) + (is-false (set-exclusive-or (list occ-1 occ-2) occs)) + (signals exceptions:missing-reference-error + (jtm::import-occurrence-from-jtm-list + (json:decode-json-from-string jtm-occ-5) parent-1 :revision 100 + :prefixes prefixes)) + (signals exceptions:JTM-error + (jtm::import-occurrence-from-jtm-list + (json:decode-json-from-string jtm-occ-4) parent-1 :revision 100 + :prefixes prefixes)) + (signals exceptions:missing-reference-error + (jtm::import-occurrence-from-jtm-list + (json:decode-json-from-string jtm-occ-3) nil :revision 100 + :prefixes prefixes)) + (signals exceptions:JTM-error + (jtm::import-occurrence-from-jtm-list + (json:decode-json-from-string jtm-occ-1) parent-1 :revision 100)) + (signals exceptions:JTM-error + (jtm::import-occurrence-from-jtm-list + (json:decode-json-from-string jtm-occ-2) nil :revision 100)) + (signals exceptions:missing-reference-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-occ-3)) nil + #'jtm::import-occurrence-from-jtm-list :revision 100 + :prefixes prefixes)) + (signals exceptions:JTM-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-occ-1)) parent-1 + #'jtm::import-occurrence-from-jtm-list :revision 100)) + (signals exceptions:JTM-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-occ-2)) nil + #'jtm::import-occurrence-from-jtm-list :revision 100))))) + + +(test test-import-names + "Tests the functions import-name-from-jtm-string and + import-constructs-from-jtm-strings." + (with-fixture with-empty-db ("data_base") + (let* ((prefixes (list (list :pref "xsd" :value *xsd-ns*) + (list :pref "pref_1" :value *xsd-ns*) + (list :pref "pref_2" :value "http://some.where/"))) + (jtm-name-1 (concat "{\"version\":\"1.1\",\"prefixes\":{\"pref_1\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"xsd\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#\",\"pref_2\":\"http:\\/\\/some.where\\/\"},\"item_identifiers\":[\"[pref_2:ii-2]\"],\"value\":\"name-1\",\"type\":\"sl:[pref_2:sl-1]\",\"item_type\":\"name\",\"parent\":[\"si:[pref_2:psi-1]\"],\"scope\":[\"si:[pref_2:psi-1]\"],\"variants\":[{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"var-1\",\"scope\":[\"sl:[pref_2:sl-1]\"],\"reifier\":null},{\"item_identifiers\":null,\"datatype\":\"http:\\/\\/www.w3.org\\/2001\\/XMLSchema#string\",\"value\":\"var-2\",\"scope\":[\"sl:[pref_2:sl-1]\"],\"reifier\":null}],\"reifier\":\"ii:[pref_2:ii-1]\"}")) + (jtm-name-2 "{\"version\":\"1.0\",\"item_identifiers\":null,\"value\":\"name-2\",\"type\":null,\"item_type\":\"name\",\"scope\":null,\"variants\":null,\"reifier\":null}") + (jtm-name-3 "{\"version\":\"1.0\",\"item_identifiers\":null,\"value\":\"name-2\",\"type\":null,\"item_type\":\"name\",\"parent\":[\"si:[pref_2:psi-10]\"],\"scope\":null,\"variants\":null,\"reifier\":null}") + (type-1 (make-construct + 'TopicC :start-revision 100 + :locators + (list (make-construct 'SubjectLocatorC + :uri "http://some.where/sl-1")))) + (parent-1 (make-construct + 'TopicC :start-revision 100 + :psis + (list (make-construct 'PersistentIdC + :uri "http://some.where/psi-1")))) + (scope-1 parent-1) + (reifier-1 (make-construct + 'TopicC :start-revision 100 + :item-identifiers + (list (make-construct 'ItemIdentifierC + :uri "http://some.where/ii-1")))) + (name-1 (jtm::import-name-from-jtm-list + (json:decode-json-from-string jtm-name-1) nil :revision 100 + :prefixes prefixes)) + (name-2 (jtm::import-name-from-jtm-list + (json:decode-json-from-string jtm-name-2) parent-1 :revision 100 + :prefixes prefixes)) + (names (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-name-1) + (json:decode-json-from-string jtm-name-2)) parent-1 + #'jtm::import-name-from-jtm-list :revision 100 + :prefixes prefixes))) + (is-true (d:find-item-by-revision name-1 100 parent-1)) + (is-false (d:find-item-by-revision name-1 50 parent-1)) + (is (eql (parent name-1 :revision 0) parent-1)) + (is (eql (parent name-2 :revision 0) parent-1)) + (is (string= (charvalue name-1) "name-1")) + (is (string= (charvalue name-2) "name-2")) + (is-false (set-exclusive-or + (map 'list #'d:uri (d:item-identifiers name-1 :revision 0)) + (list "http://some.where/ii-2") :test #'string=)) + (is-false (d:item-identifiers name-2 :revision 0)) + (is (eql (reifier name-1 :revision 0) reifier-1)) + (is-false (reifier name-2 :revision 0)) + (is-false (set-exclusive-or (themes name-1 :revision 0) (list scope-1))) + (is-false (themes name-2 :revision 0)) + (is (eql (instance-of name-1 :revision 0) type-1)) + (is-false (instance-of name-2 :revision 0)) + (is-false (set-exclusive-or + (map 'list #'d:charvalue (variants name-1 :revision 0)) + (list "var-1" "var-2") :test #'string=)) + (is-false (variants name-2 :revision 0)) + (is-false (set-exclusive-or names (list name-1 name-2))) + (signals exceptions:missing-reference-error + (jtm::import-name-from-jtm-list + (json:decode-json-from-string jtm-name-3) nil :revision 100 + :prefixes prefixes)) + (signals exceptions:JTM-error + (jtm::import-name-from-jtm-list + (json:decode-json-from-string jtm-name-1) parent-1 :revision 100)) + (signals exceptions:JTM-error + (jtm::import-name-from-jtm-list + (json:decode-json-from-string jtm-name-2) nil :revision 100)) + (signals exceptions:missing-reference-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-name-3)) nil + #'jtm::import-name-from-jtm-list :revision 100 + :prefixes prefixes)) + (signals exceptions:JTM-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-name-1)) parent-1 + #'jtm::import-name-from-jtm-list :revision 100)) + (signals exceptions:JTM-error + (jtm::import-constructs-from-jtm-lists + (list (json:decode-json-from-string jtm-name-2)) nil + #'jtm::import-name-from-jtm-list :revision 100))))) (defun run-jtm-tests()

1 0

[isidorus-cvs] r429 - in trunk/src: . json json/JTM json/isidorus-json
by Lukas Giessmann 26 Apr '11

26 Apr '11

Author: lgiessmann Date: Tue Apr 26 10:21:23 2011 New Revision: 429 Log: json: moved the json module to json/isidorus-json; added the module json/JTM; added all initila files needed by the JTM module Added: trunk/src/json/JTM/ trunk/src/json/JTM/jtm_exporter.lisp trunk/src/json/JTM/jtm_importer.lisp trunk/src/json/JTM/jtm_tools.lisp trunk/src/json/isidorus-json/ trunk/src/json/isidorus-json/json_delete_interface.lisp - copied unchanged from r331, /trunk/src/json/json_delete_interface.lisp trunk/src/json/isidorus-json/json_exporter.lisp - copied unchanged from r427, /trunk/src/json/json_exporter.lisp trunk/src/json/isidorus-json/json_importer.lisp - copied unchanged from r328, /trunk/src/json/json_importer.lisp trunk/src/json/isidorus-json/json_tmcl.lisp - copied unchanged from r384, /trunk/src/json/json_tmcl.lisp trunk/src/json/isidorus-json/json_tmcl_constants.lisp - copied unchanged from r328, /trunk/src/json/json_tmcl_constants.lisp trunk/src/json/isidorus-json/json_tmcl_validation.lisp - copied unchanged from r384, /trunk/src/json/json_tmcl_validation.lisp Removed: trunk/src/json/json_delete_interface.lisp trunk/src/json/json_exporter.lisp trunk/src/json/json_importer.lisp trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_constants.lisp trunk/src/json/json_tmcl_validation.lisp Modified: trunk/src/isidorus.asd Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue Apr 26 10:21:23 2011 @@ -200,16 +200,23 @@ "base-tools" "TM-SPARQL")) (:module "json" - :components ((:file "json_exporter" - :depends-on ("json_tmcl_constants")) - (:file "json_importer") - (:file "json_tmcl_validation" - :depends-on ("json_tmcl_constants" "json_exporter" "json_importer")) - (:file "json_tmcl_constants") - (:file "json_tmcl" - :depends-on ("json_tmcl_validation" "json_importer")) - (:file "json_delete_interface" - :depends-on ("json_importer"))) + :components ((:module "isidorus-json" + :components ((:file "json_exporter" + :depends-on ("json_tmcl_constants")) + (:file "json_importer") + (:file "json_tmcl_validation" + :depends-on ("json_tmcl_constants" "json_exporter" "json_importer")) + (:file "json_tmcl_constants") + (:file "json_tmcl" + :depends-on ("json_tmcl_validation" "json_importer")) + (:file "json_delete_interface" + :depends-on ("json_importer")))) + (:module "JTM" + :components ((:file "jtm_tools") + (:file "jtm_importer" + :depends-on ("jtm_tools")) + (:file "jtm_exporter" + :depends-on ("jtm_tools"))))) :depends-on ("base-tools" "model" "xml" Added: trunk/src/json/JTM/jtm_exporter.lisp ============================================================================== --- (empty file) +++ trunk/src/json/JTM/jtm_exporter.lisp Tue Apr 26 10:21:23 2011 @@ -0,0 +1,11 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(in-package :jtm) \ No newline at end of file Added: trunk/src/json/JTM/jtm_importer.lisp ============================================================================== --- (empty file) +++ trunk/src/json/JTM/jtm_importer.lisp Tue Apr 26 10:21:23 2011 @@ -0,0 +1,11 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(in-package :jtm) \ No newline at end of file Added: trunk/src/json/JTM/jtm_tools.lisp ============================================================================== --- (empty file) +++ trunk/src/json/JTM/jtm_tools.lisp Tue Apr 26 10:21:23 2011 @@ -0,0 +1,18 @@ +;;+----------------------------------------------------------------------------- +;;+ 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 :jtm + (:use :cl :json :datamodel) + (:export :jtm-import + :jtm-export + :*json-xtm*)) + +(in-package :jtm) + +(defvar *jtm-xtm* "jtm-xtm"); Represents the currently active TM of the JTM-Importer \ No newline at end of file

1 0

[isidorus-cvs] r428 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 26 Apr '11

26 Apr '11

Author: lgiessmann Date: Tue Apr 26 09:36:46 2011 New Revision: 428 Log: TM-SPARQL: added the possibility to search for triplles of the form "?var1 ?var2 ?var3" => adopted the corresponding unit-tests to this change Modified: trunk/src/TM-SPARQL/sparql.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 Tue Apr 26 09:36:46 2011 @@ -572,7 +572,8 @@ (let ((results (append (or (filter-by-given-subject construct :revision revision) (filter-by-given-predicate construct :revision revision) - (filter-by-given-object construct :revision revision)) + (filter-by-given-object construct :revision revision) + (filter-by-variable-triple construct :revision revision)) (filter-by-special-uris construct :revision revision)))) (map 'list #'(lambda(result) (push (getf result :subject) (subject-result construct)) @@ -583,6 +584,29 @@ results))))) +(defgeneric filter-by-variable-triple (construct &key revision) + (:documentation "Returns all graphs that match a triple consisting + only of variables.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (when (and (variable-p (subject construct)) + (variable-p (predicate construct)) + (variable-p (object construct))) + (let ((all-possible-subjects + (append (get-all-topics revision) + (get-all-occurrences revision) + (get-all-names revision) + (get-all-variants revision) + (get-all-associations revision) + (get-all-roles revision)))) + (remove-null + (loop for subj in all-possible-subjects + append (when (typep subj 'TopicC) + (append (filter-characteristics + subj nil nil nil :revision revision) + (filter-associations + subj nil nil :revision revision))))))))) + + (defgeneric filter-by-given-object (construct &key revision) (:documentation "Returns a list representing a triple that is the result of a given object.") Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Apr 26 09:36:46 2011 @@ -450,11 +450,11 @@ (is (= (length (tm-sparql::select-group q-obj-2)) 1)) (is-true q-obj-3) (is (= (length (tm-sparql::select-group q-obj-3)) 1)) - (is-false (tm-sparql::subject-result + (is-true (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1)))) - (is-false (tm-sparql::predicate-result + (is-true (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-1)))) - (is-false (tm-sparql::object-result + (is-true (tm-sparql::object-result (first (tm-sparql::select-group q-obj-1)))) (is (= (length (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-2)))) 2))

1 0

[isidorus-cvs] r427 - in trunk/src: ajax/javascripts json model rest_interface
by Lukas Giessmann 21 Apr '11

21 Apr '11

Author: lgiessmann Date: Thu Apr 21 05:56:59 2011 New Revision: 427 Log: JSON-Interface: all / that are not escaped will be escaped after calling prototypes toJSON method, because prototype does not escape /; if no topics for a player-constraint or other-player-constraint exist there is no error message thrown, instead the constraint is ignored as long as there are to few topics; the backend now escapes all /, too Modified: trunk/src/ajax/javascripts/create.js trunk/src/ajax/javascripts/datamodel.js trunk/src/ajax/javascripts/requests.js trunk/src/ajax/javascripts/tmcl_tools.js trunk/src/json/json_exporter.lisp trunk/src/model/changes.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Thu Apr 21 05:56:59 2011 @@ -130,7 +130,8 @@ alert("The fragment wasn't committed - Please correct your input data!"); return; } - + + // --- if the validation succeeded the fragment will be sent to the server var tPsis = topic.getContent().subjectIdentifiers; if(!tPsis || tPsis.length === 0) tPsis = "null"; @@ -150,6 +151,7 @@ referencedTopics = referencedTopics.concat(aStubs); } + function onSuccessHandler(topicStubs){ var tsStr = "null"; if(topicStubs && topicStubs.length !== 0){ @@ -160,17 +162,19 @@ } tsStr += "]"; } + var jTopic = "\"topic\":" + topic.toJSON(); var jTopicStubs = "\"topicStubs\":" + tsStr; var jAssociations = "\"associations\":" + (associations ? associations.toJSON().gsub("\\[\"" + CURRENT_TOPIC_ESCAPED + "\"\\]", tPsis) : "null"); var jTmId = "\"tmIds\":" + tmId.toJSON(); var json = "{" + jTopic + "," + jTopicStubs + "," + jAssociations + "," + jTmId + "}"; + commitFragment(json, function(xhr){ alert("The fragment was committed succesfully!"); }, null); } - + function onErrorHandler(){ // --- currently there is not needed a special handling for errors - // --- occurred during this operation + // --- occurring during this operation } getTopicStubs(referencedTopics, onSuccessHandler, onErrorHandler); }); Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Thu Apr 21 05:56:59 2011 @@ -549,7 +549,8 @@ }, "toJSON" : function(unique, removeNull){ var content = this.getContent(unique, removeNull); - return content.length === 0 ? "null" : content.toJSON(); + if(!content || content.length === 0) return "null"; + return content.toJSON(); }, "isValid" : function(){ var allIdentifiers = new Array(); @@ -2665,8 +2666,8 @@ this.__createFromContent__(contents); } catch(err){ - alert("From RoleContainerC(): " + err); - } + alert("From RoleContainerC(): " + err); + } }, "__orderContentsToRoles__" : function(contents, roleContainer, usedContents, alreadyUsedRoles){ if(!roleContainer || roleContainer.length === 0){ @@ -2920,31 +2921,31 @@ var cContents = contents; var usedContents = new Array(); var alreadyUsedRoles = new Array(); - + // --- searches for associaitonrole-constraints and roleplayer-constraints var ret = this.__orderContentsToRoles__(cContents, this.__arContainer__.__frames__, usedContents, alreadyUsedRoles); cContents = ret.contents; usedContents = ret.usedContents; alreadyUsedRoles = ret.alreadyUsedRoles; - + // --- searches for otherrole-constraints ret = this.__orderContentsToRoles__(cContents, this.__orContainer__.__frames__, usedContents, alreadyUsedRoles); cContents = ret.contents; usedContents = ret.usedContents; alreadyUsedRoles = ret.alreadyUsedRoles; - + // --- creates additional roles (associationrole-constraints) ret = this.__createAdditionalRolesFromContents__(cContents, usedContents, alreadyUsedRoles, true); cContents = ret.contents; usedContents = ret.usedContents; alreadyUsedRoles = ret.alreadyUsedRoles; - + // --- creates additional roles (associationrole-constraints) ret = this.__createAdditionalRolesFromContents__(cContents, usedContents, alreadyUsedRoles, false); cContents = ret.contents; usedContents = ret.usedContents; alreadyUsedRoles = ret.alreadyUsedRoles; - + this.__createNewRolesFromContents__(cContents); }, "resetValues" : function(associationRoleConstraints, rolePlayerConstraints, otherRoleConstraints){ @@ -2994,8 +2995,11 @@ var roleMin = associationRoleConstraint.cardMin === 0 ? 1 : parseInt(associationRoleConstraint.cardMin); var roleMinOrg = parseInt(associationRoleConstraint.cardMin); for(var i = 0; i !== rolePlayerConstraints.length; ++i){ + // if no player is available for a rolePlayerConstraint the constraint is ignored and no warning is thrown + if(!rolePlayerConstraints[i].players || rolePlayerConstraints[i].players.length < playerMin) continue; + + var playerMin = rolePlayerConstraints[i].cardMin === 0 ? 1 : parseInt(rolePlayerConstraints[i].cardMin); - if(rolePlayerConstraints[i].players.length < playerMin) throw "From __makeRolesFromARC__(): not enough players(=" + rolePlayerConstraints[i].players.length + ") to reach card-min(=" + playerMin + ") of roletype\"" + roleType.flatten()[0] + "\"!"; for(var k = 0; k !== playerMin; ++k){ // --- creates a new role var selectedPlayers = new Array(); @@ -3022,7 +3026,7 @@ for(var i= 0; i !== rolePlayerConstraints.length; ++i){ // existing roles --> all roles that owns a player which is selected of those listed in the roleplayer-constraint var existingRoles = this.getExistingRoles(roleType, rolePlayerConstraints[i].players, this.__arContainer__.__frames__); - var availablePlayers = rolePlayerConstraints[i].players; + var availablePlayers = (rolePlayerConstraints[i].players ? rolePlayerConstraints[i].players : new Array()); if(existingRoles.length < rolePlayerConstraints[i].cardMax && availablePlayers.length > existingRoles.length){ var currentAvailablePlayers = rolePlayerConstraints[i].players; var cleanedPlayers = cleanPlayers(allAvailablePlayers, currentAvailablePlayers); @@ -3047,7 +3051,9 @@ ++currentlyCreated; } } - if(currentlyCreated === 0) throw "Not enough players to create all needed roles of the type \"" + roleType.flatten()[0] + "\"!"; + + // not enough roles created so an association with zero roles can be made + if(currentlyCreated === 0) break; }; this.__checkARCButtons__(currentRoles, allAvailablePlayers, associationRoleConstraint); for(var i = 0; i !== currentRoles.length; ++i){ @@ -3064,7 +3070,11 @@ var cOtherRoleType = orpcs[i].otherRoleType; var cMin = orpcs[i].cardMin === 0 ? 1 : parseInt(orpcs[i].cardMin); var cMinOrg = parseInt(orpcs[i].cardMin); - if(!cOtherPlayers || cOtherPlayers.length < cMin) throw "from __makeRolesFromORC__(): not enough players(=" + cOtherPlayers.length + ") for roletype + \"" + cOtherRoleType.flatten()[0] + "\"!"; + + // if there are not enough other players the constraint is ignored and no error message is thrown + if(!cOtherPlayers || cOtherPlayers.length < cMin) continue; + + var existingRoles = this.getExistingRoles(cOtherRoleType, cOtherPlayers, this.__orContainer__.__frames__); for(var j = 0; j < cMin - existingRoles.length; ++j){ // --- removes all players that are already selected from the @@ -3471,7 +3481,7 @@ var orcs = this.__otherRoleConstraints__; var rpcs = this.__rolePlayerConstraints__; - // --- checks if there exist any constraints + // --- checks if there exist aniy constraints if(!arcs || arcs.length === 0){ this.showError("No association-constraints found for this association!"); return false; @@ -3485,20 +3495,24 @@ // --- collects all used roles depending on associationrole-constraints var allAroles = new Array(); var allAroles2 = new Array(); - for(var i = 0; this.__arContainer__.__frames__ && i !== this.__arContainer__.__frames__.length; ++i){ - this.__arContainer__.__frames__[i].hideError(); - if(this.__arContainer__.__frames__[i].isUsed() === true){ - allAroles.push(this.__arContainer__.__frames__[i]); - allAroles2.push(this.__arContainer__.__frames__[i]); + if(this.__arContainer__ && this.__arContainer__.__frames__){ + for(var i = 0; this.__arContainer__.__frames__ && i !== this.__arContainer__.__frames__.length; ++i){ + this.__arContainer__.__frames__[i].hideError(); + if(this.__arContainer__.__frames__[i].isUsed() === true){ + allAroles.push(this.__arContainer__.__frames__[i]); + allAroles2.push(this.__arContainer__.__frames__[i]); + } } } // --- collects all used roles depending on otherrole-constraints var allOroles = new Array(); - for(var i = 0; i !== this.__orContainer__.__frames__.length; ++i){ - this.__orContainer__.__frames__[i].hideError(); - if(this.__orContainer__.__frames__[i].isUsed() === true) - allOroles.push(this.__orContainer__.__frames__[i]); + if(this.__orContainer__ && this.__orContainer__.__frames__){ + for(var i = 0; i !== this.__orContainer__.__frames__.length; ++i){ + this.__orContainer__.__frames__[i].hideError(); + if(this.__orContainer__.__frames__[i].isUsed() === true) + allOroles.push(this.__orContainer__.__frames__[i]); + } } // --- checks all associationrole-constraints Modified: trunk/src/ajax/javascripts/requests.js ============================================================================== --- trunk/src/ajax/javascripts/requests.js (original) +++ trunk/src/ajax/javascripts/requests.js Thu Apr 21 05:56:59 2011 @@ -10,6 +10,13 @@ //+ trunk/src/ajax/javascripts/external/MIT-LICENSE.txt. //+----------------------------------------------------------------------------- + +// --- replaces every / character that is not prefixed by a \ character +function escapeSlashInJSON(jsonString){ + return jsonString.replace(/([^\\])\//g, '$1\\/').replace(/([^\\])\//g, '$1\\/'); +} + + // --- Sets a timeout function which alerts a message. function setAjaxTimeout(time, url) { @@ -208,7 +215,7 @@ new Ajax.Request(COMMIT_URL, { "method" : "post", - "postBody" : json, + "postBody" : escapeSlashInJSON(json), "onSuccess" : createXHRHandler(onSuccessHandler, timeFun), "onFailure" : createXHRHandler(onFailure, timeFun)}); } @@ -228,7 +235,7 @@ var timeFun = setAjaxTimeout(TIMEOUT, COMMIT_URL); new Ajax.Request(MARK_AS_DELETED_URL, { "method" : "delete", - "postBody" : json, + "postBody" : escapeSlashInJSON(json), "onSuccess" : createXHRHandler(onSuccessHandler, timeFun), "onFailure" : createXHRHandler(onFailure, timeFun)}); } Modified: trunk/src/ajax/javascripts/tmcl_tools.js ============================================================================== --- trunk/src/ajax/javascripts/tmcl_tools.js (original) +++ trunk/src/ajax/javascripts/tmcl_tools.js Thu Apr 21 05:56:59 2011 @@ -163,6 +163,7 @@ if(!anyConstraints || anyConstraints.length === 0) return players; for(var i = 0; i !== anyConstraints.length; ++i){ + if(!anyConstraints[i].players) return players; for(var j = 0; j !== anyConstraints[i].players.length; ++j){ players.push(anyConstraints[i].players[j]) } Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Thu Apr 21 05:56:59 2011 @@ -36,8 +36,9 @@ (or (eql what 'psis) (eql what 'item-identifiers) (eql what 'locators))) - (let ((items - (map 'list #'uri (funcall what parent-construct :revision revision)))) + (let ((items + (map 'list #'uri + (funcall what parent-construct :revision revision)))) (json:encode-json-to-string items)))) Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp (original) +++ trunk/src/model/changes.lisp Thu Apr 21 05:56:59 2011 @@ -37,10 +37,11 @@ (:documentation "Finds all associations for a topic.") (:method ((instance TopicC) &key (revision *TM-REVISION*)) (declare (type (or integer null) revision)) - (remove-duplicates - (map 'list #'(lambda(role) - (parent role :revision revision)) - (player-in-roles instance :revision revision))))) + (remove-null + (remove-duplicates + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles instance :revision revision)))))) (defgeneric find-associations (instance &key revision) 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 Thu Apr 21 05:56:59 2011 @@ -548,7 +548,7 @@ (let ((topictype (get-item-by-psi json-tmcl-constants::*topictype-psi* :revision 0)) (topictype-constraint (json-tmcl::is-type-constrained :revision 0))) - (format t "~%initialize cache: ") + (format t "~%initializing cache: ") (map 'list #'(lambda(top) (format t ".") (push-to-cache top topictype topictype-constraint)) @@ -576,7 +576,7 @@ (defun init-fragments () "Creates fragments of all topics that have a PSI." - (format t "create fragments: ") + (format t "creating fragments: ") (map 'list #'(lambda(top) (let ((psis-of-top (psis top))) (when psis-of-top

1 0

[isidorus-cvs] r426 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 08 Apr '11

08 Apr '11

Author: lgiessmann Date: Fri Apr 8 04:49:14 2011 New Revision: 426 Log: TM-SPARQL: finished the implementation of the SPARQL-API; finished the unit-tests of the SPARQL-API Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.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 Fri Apr 8 04:49:14 2011 @@ -10,7 +10,7 @@ (defpackage :filter-functions (:use :base-tools :constants :tm-sparql) - (:import-from :cl progn handler-case let)) + (:import-from :cl progn handler-case let condition)) (defun filter-functions::normalize-value (value) @@ -149,7 +149,8 @@ :case-insensitive-mode case-insensitive :multi-line-mode multi-line :single-line-mode single-line))) - (ppcre:scan scanner local-str))) + (when (ppcre:scan scanner local-str) + t))) (defun filter-functions::write-to-symbol (name-string) @@ -187,11 +188,4 @@ (defun filter-functions::str(x) - ;(if (stringp x) ;TODO: remove - ;(if (and (base-tools:string-starts-with x "<") - ;(base-tools:string-ends-with x ">") - ;(base-tools:absolute-uri-p (subseq x 1 (1- (length x))))) - ;(subseq x 1 (1- (length x))) - ;x) - ;(write-to-string x))) - (write-to-string x)) \ No newline at end of file + (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 Fri Apr 8 04:49:14 2011 @@ -511,13 +511,13 @@ (variable-p (cond ((eql what :subject) (and (variable-p (subject construct)) - (value (subject construct)))) + (string= (value (subject construct)) variable-name))) ((eql what :predicate) (and (variable-p (predicate construct)) - (value (predicate construct)))) + (string= (value (predicate construct)) variable-name))) ((eql what :object) (and (variable-p (object construct)) - (value (object construct))))))) + (string= (value (object construct)) variable-name)))))) (when variable-p (remove-null (dotimes (idx (length local-results)) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Fri Apr 8 04:49:14 2011 @@ -2403,18 +2403,45 @@ (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) (let* ((q-1 (concat - "SELECT * WHERE { + "SELECT ?pred1 ?obj3 ?obj1 WHERE { <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82 FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1 FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe' FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1) FILTER (DATATYPE(?obj1) = '" *xml-string* "' || DATATYPE(?obj1) = '" *xml-integer* "') && !(DATATYPE(?obj1) = '" *xml-double* "') - FILTER STR(?obj1) = '82' || ?obj1='von Goethe'" + FILTER STR(?obj1) = '82' || ?obj1='von Goethe' + FILTER ?obj1 = 82 || REGEX(STR(?obj1), 'von G.*') + ?subj3 <" *tms-value* "> ?obj3. + FILTER REGEX(?obj3, 'e.+e.+')" "}")) (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) - ;(is-true (= (length r-1) 2)) - (format t "~a~%" r-1)))) + (is-true (= (length r-1) 3)) + (map 'list #'(lambda(item) + (cond + ((string= (getf item :variable) "pred1") + (is (= (length (getf item :result)) 2)) + (is (find "<http://some.where/tmsparql/last-name>" + (getf item :result) :test #'string=)) + (is (find "<http://some.where/tmsparql/years>" + (getf item :result) :test #'string=))) + ((string= (getf item :variable) "obj1") + (is (= (length (getf item :result)) 2)) + (is (find 82 (getf item :result) :test #'tm-sparql::literal=)) + (is (find "von Goethe" (getf item :result) + :test #'tm-sparql::literal=))) + ((string= (getf item :variable) "obj3") + (is (= (length (getf item :result)) 2)) + (is-true (find "Der Zauberlehrling" (getf item :result) + :test #'string=)) + (is-true (find "Hat der alte Hexenmeister + sich doch einmal wegbegeben! + ..." (getf item :result) :test #'string=))) + (t + (is-true (format t "bad variable-name found ~a" + (getf item :variable)))))) + + r-1))))

1 0

[isidorus-cvs] r425 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 07 Apr '11

07 Apr '11

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

1 0