[isidorus-cvs] r462 - in trunk/src: base-tools json/JTM rest_interface unit_tests xml/rdf xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Mon May 9 13:58:45 UTC 2011
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)
More information about the Isidorus-cvs
mailing list