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