[isidorus-cvs] r456 - in trunk/src: json/JTM unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Sat May 7 22:02:57 UTC 2011
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
More information about the Isidorus-cvs
mailing list