[isidorus-cvs] r455 - in trunk/src: json/JTM model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri May 6 23:02:36 UTC 2011
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()
More information about the Isidorus-cvs
mailing list