Author: lgiessmann Date: Mon May 9 09:58:45 2011 New Revision: 462 Log: JTM: added the functions: make-prefix-list-from-jtm-list, import-construct-from-jtm-string, import-from-jtm, import-topic-map-from-jtm-list, and import-role-from-jtm-list Modified: trunk/src/base-tools/base-tools.lisp trunk/src/json/JTM/jtm_aliases.lisp trunk/src/json/JTM/jtm_importer.lisp trunk/src/json/JTM/jtm_tools.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/unit_tests/jtm_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/xtm/setup.lisp Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Mon May 9 09:58:45 2011 @@ -46,7 +46,8 @@ :prefix-of-uri :get-store-spec :open-tm-store - :close-tm-store)) + :close-tm-store + :read-file)) (in-package :base-tools) @@ -576,9 +577,21 @@ "Wraps the function elephant:open-store with the key-parameter :register, so one store canbe used by several instances of isidorus in parallel." - (elephant:open-store (get-store-spec pathname) :register t)) + (if elephant:*store-controller* + (elephant:open-store (get-store-spec pathname) :register t) + elephant:*store-controller*)) (defun close-tm-store () "Wraps the function elephant:close-store." - (elephant:close-store)) \ No newline at end of file + (elephant:close-store)) + + +(defun read-file (file-path) + "A helper function that reads a file and returns the content as a string." + (with-open-file (stream file-path) + (let ((file-string "")) + (do ((l (read-line stream) (read-line stream nil 'eof))) + ((eq l 'eof)) + (base-tools:push-string (base-tools::concat l (string #\newline)) file-string)) + (subseq file-string 0 (max 0 (1- (length file-string))))))) \ No newline at end of file Modified: trunk/src/json/JTM/jtm_aliases.lisp ============================================================================== --- trunk/src/json/JTM/jtm_aliases.lisp (original) +++ trunk/src/json/JTM/jtm_aliases.lisp Mon May 9 09:58:45 2011 @@ -11,6 +11,7 @@ (:use :cl :json :datamodel :base-tools :isidorus-threading :constants :exceptions :jtm) (:export :import-from-jtm + :import-form-jtm-string :export-as-jtm :export-as-jtm-string :export-construct-as-jtm-string 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 09:58:45 2011 @@ -10,17 +10,119 @@ (in-package :jtm) -;TODO: write a generic outer method that evaluates the item_type, -; version, parent, and prefixes and finally calls a special -; function that creates a construct - - (defun get-item (item-keyword jtm-list) (declare (Keyword item-keyword) (List jtm-list)) (rest (find item-keyword jtm-list :key #'first))) +(defun make-prefix-list-from-jtm-list (jtm-list) + "Creates a plist of the form ((:pref 'pref_1' :value 'value-1') + (:pref 'pref_2' :value 'value-2')) if the passed jtm-list is + of the form ((:PREF--1 . 'value-1')(:PREF--2 . 'value-2'))." + (declare (List jtm-list)) + (loop for item in jtm-list + collect (list :pref (json:lisp-to-camel-case + (subseq (write-to-string (first item)) 1)) + :value (rest item)))) + + +(defun import-construct-from-jtm-string (jtm-string &key + (revision *TM-REVISION*) + (jtm-format :1.1) tm-id) + "Imports the passed jtm-string. + Note tm-id needs not to be declared, but if the imported construct + is a topicmap and it has no item-identifiers defined, a JTM-error + is thrown." + (declare (String jtm-string) + (type (or Null String) tm-id)) + + (let* ((jtm-list (json:decode-json-from-string jtm-string)) + (version (get-item :VERSION jtm-list)) + (item_type (get-item :ITEM--TYPE jtm-list)) + (prefixes (make-prefix-list-from-jtm-list (get-item :PREFIXES jtm-list))) + (format-1.1-p (eql jtm-format :1.1))) + (cond ((eql jtm-format :1.0) + (unless (string= version "1.0") + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member version must be set to \"1.0\" in JTM version 1.0, but is ~a" version)))) + (when prefixes + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member prefixes must not be set when using JTM version 1.0, but found: ~a" prefixes))))) + ((eql jtm-format :1.1) + (unless (string= version "1.1") + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member version must be set to \"1.1\" in JTM version 1.1, but is ~a" version))))) + (t + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): only JTM format 1.0 and 1.1 is supported, but found: ~a" jtm-format))))) + (cond ((or (not item_type) + (string= item_type item_type-topicmap)) + (import-topic-map-from-jtm-list + jtm-list tm-id :revision revision :prefixes prefixes + :instance-of-p format-1.1-p)) + ((string= item_type item_type-topic) + (import-topic-stub-from-jtm-list jtm-list nil :revision revision + :prefixes prefixes) + (merge-topic-from-jtm-list jtm-list nil :instance-of-p format-1.1-p + :revision revision :prefixes prefixes)) + ((string= item_type item_type-name) + (import-name-from-jtm-list jtm-list nil :revision revision + :prefixes prefixes)) + ((string= item_type item_type-variant) + (import-variant-from-jtm-list jtm-list nil :revision revision + :prefixes prefixes)) + ((string= item_type item_type-occurrence) + (import-occurrence-from-jtm-list jtm-list nil :revision revision + :prefixes prefixes)) + ((string= item_type item_type-role) + (import-role-from-jtm-list jtm-list nil :revision revision + :prefixes prefixes)) + ((string= item_type item_type-association) + (import-association-from-jtm-list jtm-list nil :revision revision + :prefixes prefixes)) + (t + (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-string(): the member \"item_type\" must be set to one of ~a or nil, but found \"~a\". If \"item_type\" is not specified or nil the JTM-data is treated as a topicmap." item_type (list item_type-topicmap item_type-topic item_type-name item_type-variant item_type-occurrence item_type-role item_type-association)))))))) + + +(defun import-from-jtm (jtm-path repository-path &key (tm-id (error "you must provide a stable identifier (PSI-style) for this TM")) (revision *TM-REVISION*) (jtm-format :1.1)) + "Imports the given jtm-file by calling import-construct-from-jtm-string." + (declare (type (or Pathname String) jtm-path repository-path) + (String tm-id) + (Keyword jtm-format) + (Integer revision)) + (open-tm-store repository-path) + (import-construct-from-jtm-string (read-file jtm-path) :tm-id tm-id :revision revision + :jtm-format jtm-format) + (close-tm-store)) + + +(defun import-topic-map-from-jtm-list (jtm-list tm-id &key (revision *TM-REVISION*) + prefixes (instance-of-p t)) + "Creates and returns a topic map corresponding to the tm-id or a given + item-identifier in the jtm-list and returns the tm construct after all + topics and associations contained in the jtm-list has been created." + (declare (List jtm-list prefixes) + (Integer revision) + (Boolean instance-of-p)) + (let* ((iis (let ((value (append (import-identifiers-from-jtm-strings + (get-item :ITEM--IDENTIFIERS jtm-list) + :prefixes prefixes) + (when tm-id + (make-construct 'ItemIdentifierC + :uri tm-id))))) + (unless value + (error (make-condition 'JTM-error :message (format nil "From import-topic-map-from-jtm-list(): no topic-map item-identifier is set for ~a" jtm-list)))) + value)) + (j-tops (get-item :TOPICS jtm-list)) + (j-assocs (get-item :ASSOCIATIONS jtm-list)) + (tm (make-construct 'TopicMapC :start-revision revision + :item-identifiers iis))) + (import-topic-stubs-from-jtm-lists j-tops (list tm) :revision revision + :prefixes prefixes) + (merge-topics-from-jtm-lists j-tops (list tm) :instance-of-p instance-of-p + :revision revision :prefixes prefixes) + (import-associations-from-jtm-lists j-assocs (list tm) :revision revision + :prefixes prefixes) + tm)) + + (defun import-associations-from-jtm-lists (jtm-lists parents &key (revision *TM-REVISION*) prefixes) "Create a listof AssociationC objects corresponding to the passed jtm-lists @@ -33,6 +135,40 @@ jtm-lists)) +(defun import-role-from-jtm-list (jtm-list parent &key (revision *TM-REVISION*) + prefixes) + "Creates and returns a role object form the given jtm-list." + (let* ((iis (import-identifiers-from-jtm-strings + (get-item :ITEM--IDENTIFIERS jtm-list) + :prefixes prefixes)) + (type (get-item :TYPE jtm-list)) + (reifier (get-item :REIFIER jtm-list)) + (player (get-item :PLAYER jtm-list)) + (parent-reference (get-item :PARENT jtm-list)) + (local-parent + (if parent + parent + (when parent-reference + (get-item-from-jtm-reference + parent-reference :revision revision :prefixes prefixes))))) + (unless local-parent + (error (make-condition 'JTM-error :message (format nil "From import-role-from-jtm-list(): the JTM role ~a must have exactly one parent set in its members." jtm-list)))) + (unless type + (error (make-condition 'JTM-error :message (format nil "From import-role-from-jtm-list(): the role ~a must have exactly one type set as member." jtm-list)))) + (unless player + (error (make-condition 'JTM-error :message (format nil "From import-role-from-jtm-list(): the role ~a must have exactly one player set as member." jtm-list)))) + (make-construct 'RoleC :start-revision revision + :item-identifiers iis + :reifier (when reifier + (get-item-from-jtm-reference + reifier :revision revision :prefixes prefixes)) + :instance-of (get-item-from-jtm-reference + type :revision revision :prefixes prefixes) + :player (get-item-from-jtm-reference + player :revision revision :prefixes prefixes) + :parent local-parent))) + + (defun make-plist-of-jtm-role(jtm-list &key (revision *TM-REVISION*) prefixes) "Returns a plist of the form (:start-revision <rev> :player <top> :instance-of <top> :reifier <top> :item-identifiers <ii>)." Modified: trunk/src/json/JTM/jtm_tools.lisp ============================================================================== --- trunk/src/json/JTM/jtm_tools.lisp (original) +++ trunk/src/json/JTM/jtm_tools.lisp Mon May 9 09:58:45 2011 @@ -11,10 +11,10 @@ (:use :cl :json :datamodel :base-tools :isidorus-threading :constants :exceptions) (:export :import-from-jtm + :import-construct-from-jtm-string :export-as-jtm :export-as-jtm-string :export-construct-as-jtm-string - :*jtm-xtm* :item_type-topicmap :item_type-topic :item_type-name @@ -25,8 +25,6 @@ (in-package :jtm) -(defvar *jtm-xtm* "jtm-xtm"); Represents the currently active TM of the JTM-Importer - (defvar item_type-topicmap "topicmap") (defvar item_type-topic "topic") Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Mon May 9 09:58:45 2011 @@ -82,8 +82,7 @@ (setf hunchentoot:*show-lisp-errors-p* t) ;for now (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) - (unless elephant:*store-controller* - (open-tm-store repository-path)) + (open-tm-store repository-path) (set-up-json-interface) (setf *json-server-acceptor* (make-instance 'hunchentoot:acceptor :address host-name :port port)) @@ -111,8 +110,7 @@ (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (setf atom:*base-url* (format nil "http://~a:~a" host-name port)) - (unless elephant:*store-controller* - (open-tm-store repository-path)) + (open-tm-store repository-path) (load conf-file) (publish-feed atom:*tm-feed*) (setf *atom-server-acceptor* 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 09:58:45 2011 @@ -49,16 +49,6 @@ (in-package :jtm-test) -(defun read-file (file-path) - "A helper function that reads a file and returns the content as a string." - (with-open-file (stream file-path) - (let ((file-string "")) - (do ((l (read-line stream) (read-line stream nil 'eof))) - ((eq l 'eof)) - (base-tools:push-string (base-tools::concat l (string #\newline)) file-string)) - (subseq file-string 0 (max 0 (1- (length file-string))))))) - - (def-suite jtm-tests :description "tests various functions of the jtm module") @@ -1639,7 +1629,7 @@ (test test-make-instance-of-association - "Tests the function make-instance-of-association." + "Tests the function make-instance-of-association."1 (with-fixture with-empty-db ("data_base") (let* ((tt (make-construct 'TopicC :start-revision 100 :psis @@ -2211,6 +2201,12 @@ +;TODO: +; *import-role-from-jtm-list +; *import-construct-from-jtm-string +; *import-from-jtm +; *import-topic-map-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 Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon May 9 09:58:45 2011 @@ -15,8 +15,7 @@ to the give file path is imported." (declare ((or pathname string) rdf-xml-path)) (declare ((or pathname string) repository-path)) - (unless elephant:*store-controller* - (open-tm-store repository-path)) + (open-tm-store repository-path) (xtm-importer:init-isidorus) (init-rdf-module) (import-from-rdf rdf-xml-path repository-path :tm-id tm-id @@ -34,8 +33,7 @@ (setf *document-id* document-id) (tm-id-p tm-id "rdf-importer") (with-writer-lock - (unless elephant:*store-controller* - (open-tm-store repository-path)) + (open-tm-store repository-path) (let ((rdf-dom (dom:document-element (cxml:parse-file (truename rdf-xml-path) Modified: trunk/src/xml/xtm/setup.lisp ============================================================================== --- trunk/src/xml/xtm/setup.lisp (original) +++ trunk/src/xml/xtm/setup.lisp Mon May 9 09:58:45 2011 @@ -26,8 +26,7 @@ (let ((xtm-dom (dom:document-element (cxml:parse-file (truename xtm-path) (cxml-dom:make-dom-builder))))) - (unless elephant:*store-controller* - (open-tm-store repository-path)) + (open-tm-store repository-path) ;create the topic stubs so that we can refer to them later on (setf d:*current-xtm* xtm-id) (if (eq xtm-format :2.0) @@ -48,8 +47,7 @@ (declare (type (or pathname string) xtm-path repository-path) (String tm-id xtm-id) (Keyword xtm-format)) - (unless elephant:*store-controller* - (open-tm-store repository-path)) + (open-tm-store repository-path) (init-isidorus) (import-from-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)