[isidorus-cvs] r977 - in trunk: playground/GWT-Examples src src/TM-SPARQL src/anaToMia src/json/JTM src/model src/rest_interface src/xml/xtm
lgiessmann at common-lisp.net
lgiessmann at common-lisp.net
Mon Sep 26 11:56:27 UTC 2011
Author: lgiessmann
Date: Mon Sep 26 04:56:25 2011
New Revision: 977
Log:
trunk: merged branches/gdl-frontend with trunk; fixed all conflicts
Added:
trunk/playground/GWT-Examples/
- copied from r976, branches/gdl-frontend/playground/GWT-Examples/
trunk/src/anaToMia/
- copied from r976, branches/gdl-frontend/src/anaToMia/
trunk/src/json/JTM/jtm_delete_interface.lisp
- copied unchanged from r976, branches/gdl-frontend/src/json/JTM/jtm_delete_interface.lisp
trunk/src/rest_interface/set-up-gdl-interface.lisp
- copied unchanged from r976, branches/gdl-frontend/src/rest_interface/set-up-gdl-interface.lisp
Modified:
trunk/src/TM-SPARQL/sparql_parser.lisp
trunk/src/isidorus.asd
trunk/src/json/JTM/jtm_aliases.lisp
trunk/src/json/JTM/jtm_importer.lisp
trunk/src/json/JTM/jtm_tools.lisp
trunk/src/model/changes.lisp
trunk/src/rest_interface/rest-interface.lisp
trunk/src/rest_interface/set-up-json-interface.lisp
trunk/src/xml/xtm/exporter.lisp
Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -427,7 +427,7 @@
(progn (add-variable construct "*")
(parse-variables construct (string-after trimmed-str "*")))
(let ((result (parse-variable-name construct trimmed-str)))
- (add-variable construct (getf result :value))
+ (add-variable construct (trim-whitespace-right (getf result :value)))
(parse-variables construct (getf result :next-query))))))))
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/isidorus.asd Mon Sep 26 04:56:25 2011 (r977)
@@ -113,6 +113,9 @@
:depends-on ("rest-interface"))
(:file "admin-interface"
:depends-on ("rest-interface"))
+ (:file "set-up-gdl-interface"
+ :depends-on ("rest-interface"
+ "set-up-json-interface"))
(:file "read"
:depends-on ("rest-interface")))
:depends-on ("model" "atom" "xml" "TM-SPARQL"
@@ -210,6 +213,8 @@
:depends-on ("jtm_tools"))
(:file "jtm_exporter"
:depends-on ("jtm_tools"))
+ (:file "jtm_delete_interface"
+ :depends-on ("jtm_tools" "jtm_importer"))
(:file "jtm_aliases"
:depends-on ("jtm_tools" "jtm_importer" "jtm_exporter")))))
:depends-on ("base-tools" "model" "xml" "TM-SPARQL"))
Modified: trunk/src/json/JTM/jtm_aliases.lisp
==============================================================================
--- trunk/src/json/JTM/jtm_aliases.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/json/JTM/jtm_aliases.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -27,10 +27,17 @@
:constants :exceptions :jtm)
(:export :import-from-jtm
:import-construct-from-jtm-string
+ :import-construct-from-jtm-decoded-list
:item_type-topicmap
:item_type-topic
:item_type-name
:item_type-variant
:item_type-occurrence
:item_type-association
- :item_type-role))
\ No newline at end of file
+ :item_type-role))
+
+
+(defpackage :jtm-delete-interface
+ (:use :cl :json :datamodel :base-tools :isidorus-threading
+ :constants :exceptions :jtm)
+ (:export :mark-as-deleted-from-jtm))
\ No newline at end of file
Copied: trunk/src/json/JTM/jtm_delete_interface.lisp (from r976, branches/gdl-frontend/src/json/JTM/jtm_delete_interface.lisp)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/json/JTM/jtm_delete_interface.lisp Mon Sep 26 04:56:25 2011 (r977, copy of r976, branches/gdl-frontend/src/json/JTM/jtm_delete_interface.lisp)
@@ -0,0 +1,393 @@
+;;+-----------------------------------------------------------------------------
+;;+ Isidorus
+;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
+;;+
+;;+ Isidorus is freely distributable under the LLGPL license.
+;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
+;;+ trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+(defpackage :jtm-delete-interface
+ (:use :cl :datamodel :jtm)
+ (:export :mark-as-deleted-from-jtm))
+
+(in-package :jtm-delete-interface)
+
+(defun mark-as-deleted-from-jtm (jtm-data &key (revision *TM-REVISION*))
+ "Marks an object that is specified by the given JSON data as deleted."
+ (declare (string jtm-data) (integer revision))
+ (let ((json-list (json:decode-json-from-string jtm-data)))
+ (let ((type nil)
+ (parent nil)
+ (parent-of-parent nil)
+ (delete nil))
+ (loop for json-entry in json-list
+ do (let ((st (car json-entry))
+ (nd (cdr json-entry)))
+ (cond ((eql st :type)
+ (setf type nd))
+ ((eql st :delete)
+ (setf delete nd))
+ ((eql st :parent)
+ (setf parent nd))
+ ((eql st :parent-of-parent)
+ (setf parent-of-parent nd)))))
+ (cond ((string= type "Topic")
+ (delete-topic-from-jtm delete :revision revision))
+ ((string= type "PSI")
+ (delete-identifier-from-jtm delete 'd:PersistentIdC
+ #'d:delete-psi :revision revision))
+ ((string= type "ItemIdentity")
+ (delete-identifier-from-jtm delete 'd:ItemIdentifierC
+ #'d:delete-item-identifier
+ :revision revision))
+ ((string= type "SubjectLocator")
+ (delete-identifier-from-jtm delete 'd:SubjectLocatorC
+ #'d:delete-locator :revision revision))
+ ((string= type "Name")
+ (delete-name-from-jtm delete :revision revision))
+ ((string= type "Variant")
+ (delete-variant-from-jtm delete :revision revision))
+ ((string= type "Occurrence")
+ (delete-occurrence-from-jtm delete :revision revision))
+ ((string= type "Association")
+ (delete-association-from-jtm delete :revision revision))
+ ((string= type "Role")
+ (delete-role-from-jtm delete :revision revision))
+ (t
+ (error "Type \"~a\" is not defined" type))))))
+
+
+(defun delete-role-from-jtm (jtm-decoded-list
+ &key (revision *TM-REVISION*))
+ "Deletes the passed role object and returns t otherwise this
+ function returns nil."
+ (declare (list jtm-decoded-list) (integer revision))
+ (let* ((prefs (jtm::make-prefix-list-from-jtm-list
+ (jtm::get-item :PREFIXES jtm-decoded-list)))
+ (ii
+ (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list)))
+ (when curies
+ (jtm::compute-uri-from-jtm-identifier (first curies) prefs))))
+ (type
+ (let ((curie (jtm::get-item :TYPE jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference curie :revision revision
+ :prefixes prefs))))
+ (reifier
+ (let ((curie (jtm::get-item :REIFIER jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference
+ curie :revision revision :prefixes prefs))))
+ (parent
+ (let* ((curies (jtm::get-item :PARENT jtm-decoded-list))
+ (parents (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (when parents
+ (first parents))))
+ (player-top
+ (let ((curie (jtm::get-item :PLAYER jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference curie :revision revision
+ :prefixes prefs)))))
+ (let ((role-to-delete
+ (cond (ii
+ (identified-construct ii :revision revision))
+ (reifier
+ (reified-construct reifier :revision revision))
+ (parent
+ (let ((found-roles
+ (tools:remove-null
+ (map 'list (lambda(role)
+ (when (d::equivalent-construct
+ role :start-revision revision
+ :player player-top
+ :instance-of type)
+ role))
+ (roles parent :revision revision)))))
+ (when found-roles
+ (first found-roles))))
+ (t
+ (error "when deleting a role, there must be an item-identifier, reifier or parent set!")))))
+ (when role-to-delete
+ (delete-role (parent role-to-delete :revision revision)
+ role-to-delete :revision revision)
+ role-to-delete))))
+
+
+
+
+(defun delete-association-from-jtm (jtm-decoded-list &key
+ (revision *TM-REVISION*))
+ "Deletes the passed association object and returns t otherwise this
+ function returns nil."
+ (declare (list jtm-decoded-list) (integer revision))
+ (let* ((prefs (jtm::make-prefix-list-from-jtm-list
+ (jtm::get-item :PREFIXES jtm-decoded-list)))
+ (ii
+ (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list)))
+ (when curies
+ (jtm::compute-uri-from-jtm-identifier (first curies) prefs))))
+ (scope
+ (let ((curies (jtm::get-item :SCOPE jtm-decoded-list)))
+ (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (type
+ (let ((curie (jtm::get-item :TYPE jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference curie :revision revision
+ :prefixes prefs))))
+ (reifier
+ (let ((curie (jtm::get-item :REIFIER jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference
+ curie :revision revision :prefixes prefs))))
+ (roles
+ (map 'list (lambda(jtm-role)
+ (jtm::make-plist-of-jtm-role
+ jtm-role :revision revision :prefixes prefs))
+ (jtm::get-item :ROLES jtm-decoded-list))))
+ (let ((assoc-to-delete
+ (cond (ii
+ (identified-construct ii :revision revision))
+ (reifier
+ (reified-construct reifier :revision revision))
+ (t
+ (let ((found-assocs
+ (tools:remove-null
+ (map 'list (lambda(assoc)
+ (d::equivalent-construct
+ assoc :start-revision revision
+ :roles roles :instance-of type
+ :themes scope))
+ (get-all-associations revision)))))
+ (when found-assocs
+ (first found-assocs)))))))
+ (when assoc-to-delete
+ (mark-as-deleted assoc-to-delete :revision revision)
+ assoc-to-delete))))
+
+
+(defun delete-variant-from-jtm (jtm-decoded-list
+ &key (revision *TM-REVISION*))
+ "Deletes the passed variant from the given name and returns t if the
+ operation succeeded."
+ (declare (list jtm-decoded-list) (integer revision))
+ (let* ((prefs (jtm::make-prefix-list-from-jtm-list
+ (jtm::get-item :PREFIXES jtm-decoded-list)))
+ (ii
+ (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list)))
+ (when curies
+ (jtm::compute-uri-from-jtm-identifier (first curies) prefs))))
+ (value (jtm::get-item :VALUE jtm-decoded-list))
+ (datatype (jtm::get-item :DATATYPE jtm-decoded-list))
+ (scope
+ (let ((curies (jtm::get-item :SCOPE jtm-decoded-list)))
+ (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (parent
+ (let* ((curies (jtm::get-item :PARENT jtm-decoded-list))
+ (parents (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (when parents
+ (first parents))))
+ (reifier
+ (let ((curie (jtm::get-item :REIFIER jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference
+ curie :revision revision :prefixes prefs)))))
+ (let ((var-to-delete
+ (cond (ii
+ (identified-construct ii :revision revision))
+ (reifier
+ (reified-construct reifier :revision revision))
+ (parent
+ (let ((found-vars
+ (tools:remove-null
+ (map 'list (lambda(var)
+ (when (d::equivalent-construct
+ var :start-revision revision
+ :charvalue value :themes scope
+ :datatype datatype)
+ var))
+ (variants parent :revision revision)))))
+ (when found-vars
+ (first found-vars))))
+ (t
+ (error "when deleting a variant, there must be an item-identifier, reifier or parent set!")))))
+ (when var-to-delete
+ (delete-variant (parent var-to-delete :revision revision)
+ var-to-delete :revision revision)
+ var-to-delete))))
+
+
+(defun delete-occurrence-from-jtm (jtm-decoded-list
+ &key (revision *TM-REVISION*))
+ "Deletes the passed occurrence from the given topic and returns t if the
+ operation succeeded."
+ (declare (list jtm-decoded-list) (integer revision))
+ (let* ((prefs (jtm::make-prefix-list-from-jtm-list
+ (jtm::get-item :PREFIXES jtm-decoded-list)))
+ (ii
+ (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list)))
+ (when curies
+ (jtm::compute-uri-from-jtm-identifier (first curies) prefs))))
+ (value (jtm::get-item :VALUE jtm-decoded-list))
+ (datatype
+ (let ((curie (jtm::get-item :DATATYPE jtm-decoded-list)))
+ (cond ((null curie)
+ constants:*xml-string*)
+ ((and (tools:string-starts-with curie "[")
+ (tools:string-ends-with curie "]"))
+ (jtm::compute-uri-from-jtm-identifier curie prefs))
+ (t
+ curie))))
+ (type
+ (let ((curie (jtm::get-item :TYPE jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference curie :revision revision
+ :prefixes prefs))))
+ (scope
+ (let ((curies (jtm::get-item :SCOPE jtm-decoded-list)))
+ (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (parent
+ (let* ((curies (jtm::get-item :PARENT jtm-decoded-list))
+ (parents (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (when parents
+ (first parents))))
+ (reifier
+ (let ((curie (jtm::get-item :REIFIER jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference
+ curie :revision revision :prefixes prefs)))))
+ (let ((occ-to-delete
+ (cond (ii
+ (identified-construct ii :revision revision))
+ (reifier
+ (reified-construct reifier :revision revision))
+ (parent
+ (let ((found-occs
+ (tools:remove-null
+ (map 'list (lambda(occ)
+ (when (d::equivalent-construct
+ occ :start-revision revision
+ :charvalue value :themes scope
+ :instance-of type :datatype datatype)
+ occ))
+ (occurrences parent :revision revision)))))
+ (when found-occs
+ (first found-occs))))
+ (t
+ (error "when deleting an occurrence, there must be an item-identifier, reifier or parent set!")))))
+ (when occ-to-delete
+ (delete-occurrence (parent occ-to-delete :revision revision)
+ occ-to-delete :revision revision)
+ occ-to-delete))))
+
+
+(defun delete-name-from-jtm (jtm-decoded-list
+ &key (revision *TM-REVISION*))
+ (declare (list jtm-decoded-list) (integer revision))
+ (let* ((prefs (jtm::make-prefix-list-from-jtm-list
+ (jtm::get-item :PREFIXES jtm-decoded-list)))
+ (ii
+ (let ((curies (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list)))
+ (when curies
+ (jtm::compute-uri-from-jtm-identifier (first curies) prefs))))
+ (value (jtm::get-item :VALUE jtm-decoded-list))
+ (type
+ (let ((curie (jtm::get-item :TYPE jtm-decoded-list)))
+ (if curie
+ (jtm::get-item-from-jtm-reference curie :revision revision
+ :prefixes prefs)
+ (get-item-by-psi constants:*topic-name-psi*
+ :revision revision :error-if-nil t))))
+ (scope
+ (let ((curies (jtm::get-item :SCOPE jtm-decoded-list)))
+ (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (parent
+ (let* ((curies (jtm::get-item :PARENT jtm-decoded-list))
+ (parents (jtm::get-items-from-jtm-references
+ curies :revision revision :prefixes prefs)))
+ (when parents
+ (first parents))))
+ (reifier
+ (let ((curie (jtm::get-item :REIFIER jtm-decoded-list)))
+ (when curie
+ (jtm::get-item-from-jtm-reference
+ curie :revision revision :prefixes prefs)))))
+ (let ((name-to-delete
+ (cond (ii
+ (identified-construct ii :revision revision))
+ (reifier
+ (reified-construct reifier :revision revision))
+ (parent
+ (let ((found-names
+ (tools:remove-null
+ (map 'list (lambda(name)
+ (when (d::equivalent-construct
+ name :start-revision revision
+ :charvalue value :themes scope
+ :instance-of type)
+ name))
+ (names parent :revision revision)))))
+ (when found-names
+ (first found-names))))
+ (t
+ (error "when deleting a name, there must be an item-identifier, reifier or parent set!")))))
+ (when name-to-delete
+ (delete-name (parent name-to-delete :revision revision)
+ name-to-delete :revision revision)
+ name-to-delete))))
+
+
+(defun delete-identifier-from-json (uri class delete-function
+ &key (revision *TM-REVISION*))
+ "Deleted the passed identifier of the construct it is associated with.
+ Returns t if there was deleted an item otherweise it returns nil."
+ (declare (string uri) (integer revision) (symbol class))
+ (let ((id (elephant:get-instance-by-value
+ class 'd:uri uri)))
+ (if (and id (typep id class))
+ (progn
+ (apply delete-function
+ (list (d:identified-construct id :revision revision)
+ id :revision revision))
+ id)
+ nil)))
+
+
+(defun delete-topic-from-jtm (jtm-decoded-list &key (revision *TM-REVISION*))
+ "Searches for a topic corresponding to the given identifiers.
+ Returns t if there was deleted an item otherweise it returns nil."
+ (declare (list jtm-decoded-list) (integer revision))
+ (let* ((prefs
+ (jtm::make-prefix-list-from-jtm-list
+ (jtm::get-item :PREFIXES jtm-decoded-list)))
+ (ids (append
+ (jtm::get-item :SUBJECT--IDENTIFIERS jtm-decoded-list)
+ (jtm::get-item :ITEM--IDENTIFIERS jtm-decoded-list)
+ (jtm::get-item :SUBJECT--LOCATORS jtm-decoded-list)))
+ (uri (if (null ids)
+ (error (make-condition 'exceptions::JTM-error :message (format nil "From merge-topic-from-jtm-list(): the passed topic has to own at least one identifier: ~a" jtm-decoded-list)))
+ (jtm::compute-uri-from-jtm-identifier (first ids) prefs))))
+ (let ((top-to-delete (get-item-by-any-id uri :revision revision)))
+ (when top-to-delete
+ (mark-as-deleted top-to-delete :source-locator uri :revision revision)
+ top-to-delete))))
+
+
+(defun delete-identifier-from-jtm (uri class delete-function
+ &key (revision *TM-REVISION*))
+ "Deleted the passed identifier of the construct it is associated with.
+ Returns t if there was deleted an item otherweise it returns nil."
+ (declare (string uri) (integer revision) (symbol class))
+ (let ((id (elephant:get-instance-by-value
+ class 'd:uri uri)))
+ (when (and id (typep id class))
+ (apply delete-function
+ (list (d:identified-construct id :revision revision)
+ id :revision revision)))))
\ No newline at end of file
Modified: trunk/src/json/JTM/jtm_importer.lisp
==============================================================================
--- trunk/src/json/JTM/jtm_importer.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/json/JTM/jtm_importer.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -29,7 +29,8 @@
(defun import-construct-from-jtm-string (jtm-string &key
(revision *TM-REVISION*)
- (jtm-format :1.1) tm-id)
+ (jtm-format :1.1) tm-id
+ (create-fragments nil))
"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
@@ -37,32 +38,52 @@
(declare (String jtm-string)
(type (or Null String) tm-id)
(Integer revision)
- (Keyword jtm-format))
- (let* ((jtm-list (json:decode-json-from-string jtm-string))
- (version (get-item :VERSION jtm-list))
+ (Keyword jtm-format)
+ (Boolean create-fragments))
+ (let* ((jtm-list (json:decode-json-from-string jtm-string)))
+ (import-construct-from-jtm-decoded-list
+ jtm-list :revision revision :jtm-format jtm-format
+ :tm-id tm-id :create-fragments create-fragments)))
+
+
+(defun import-construct-from-jtm-decoded-list (jtm-list &key
+ (revision *TM-REVISION*)
+ (jtm-format :1.1) tm-id
+ (create-fragments nil))
+ "Imports the passed jtm-decoded-list.
+ 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 (List jtm-list)
+ (Integer revision)
+ (Keyword jtm-format)
+ (type (or Null String) tm-id)
+ (Boolean create-fragments))
+ (let* ((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))))
+ (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): 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)))))
+ (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): 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)))))
+ (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): 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)))))
+ (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): 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))
+ :instance-of-p format-1.1-p :create-fragments create-fragments))
((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))
+ (merge-topic-from-jtm-list jtm-list :instance-of-p format-1.1-p
+ :revision revision :prefixes prefixes
+ :create-fragment create-fragments))
((string= item_type item_type-name)
(import-name-from-jtm-list jtm-list nil :revision revision
:prefixes prefixes))
@@ -79,7 +100,7 @@
(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))))))))
+ (error (make-condition 'exceptions:JTM-error :message (format nil "From import-construct-from-jtm-decoded-list(): 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))
@@ -96,13 +117,14 @@
(defun import-topic-map-from-jtm-list (jtm-list tm-id &key (revision *TM-REVISION*)
- prefixes (instance-of-p t))
+ prefixes (instance-of-p t)
+ (create-fragments nil))
"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))
+ (Boolean instance-of-p create-fragments))
(let* ((iis (let ((value (append (import-identifiers-from-jtm-strings
(get-item :ITEM--IDENTIFIERS jtm-list)
:prefixes prefixes)
@@ -119,8 +141,9 @@
: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)
+ (merge-topics-from-jtm-lists j-tops :instance-of-p instance-of-p
+ :revision revision :prefixes prefixes
+ :create-fragments create-fragments)
(import-associations-from-jtm-lists j-assocs (list tm) :revision revision
:prefixes prefixes)
tm))
@@ -324,30 +347,34 @@
assoc)))
-(defun merge-topics-from-jtm-lists (jtm-lists parents &key (instance-of-p t)
- (revision *TM-REVISION*) prefixes)
+(defun merge-topics-from-jtm-lists (jtm-lists &key (instance-of-p t)
+ (revision *TM-REVISION*) prefixes
+ (create-fragments nil))
"Creates and returns a list of topics."
- (declare (List jtm-lists parents prefixes)
- (Boolean instance-of-p)
+ (declare (List jtm-lists prefixes)
+ (Boolean instance-of-p create-fragments)
(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-list :revision revision :prefixes prefixes
+ :instance-of-p instance-of-p
+ :create-fragment create-fragments))
jtm-lists))
-(defun merge-topic-from-jtm-list(jtm-list parents &key (instance-of-p t)
- (revision *TM-REVISION*) prefixes)
+(defun merge-topic-from-jtm-list(jtm-list &key (instance-of-p t)
+ (revision *TM-REVISION*) prefixes
+ (create-fragment nil))
"Creates and returns a topic object from the passed jtm
list generated by json:decode-json-from-string.
Note that the merged topics are not added explicitly to the parent
topic maps, it is only needed for the instance-of-associations -
topics are added in the function import-topic-stubs-from-jtm-lists
to their topic map elements."
- (declare (List jtm-list prefixes parents)
+ (declare (List jtm-list prefixes)
(Boolean instance-of-p)
- (Integer revision))
+ (Integer revision)
+ (Boolean create-fragment))
(let* ((ids (append (get-item :ITEM--IDENTIFIERS jtm-list)
(get-item :SUBJECT--IDENTIFIERS jtm-list)
(get-item :SUBJECT--LOCATORS jtm-list)))
@@ -373,11 +400,29 @@
(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))
+ (make-instance-of-association
+ top type-top (in-topicmaps top :revision revision)
+ :revision revision))
(dolist (name top-names)
(add-name top name :revision revision))
(dolist (occ top-occs)
(add-occurrence top occ :revision revision))
+ (when create-fragment
+ (let ((all-assocs
+ (remove-null (map 'list (lambda(role)
+ (parent role :revision revision))
+ (player-in-roles top :revision revision)))))
+ (let ((all-tops
+ (remove-null
+ (loop for assoc in all-assocs
+ append (map 'list (lambda(role)
+ (d:player role :revision revision))
+ (roles assoc :revision revision))))))
+ (map nil (lambda(top)
+ (map nil #'elephant:drop-instance
+ (elephant:get-instances-by-value 'FragmentC 'topic top))
+ (create-latest-fragment-of-topic top))
+ (append all-tops (list top))))))
(format t "t")
top))
@@ -438,7 +483,15 @@
(let* ((iis (import-identifiers-from-jtm-strings
(get-item :ITEM--IDENTIFIERS jtm-list)
:prefixes prefixes))
- (datatype (get-item :DATATYPE jtm-list))
+ (datatype
+ (let ((curie (jtm::get-item :DATATYPE jtm-list)))
+ (cond ((null curie)
+ constants:*xml-string*)
+ ((and (tools:string-starts-with curie "[")
+ (tools:string-ends-with curie "]"))
+ (jtm::compute-uri-from-jtm-identifier curie prefixes))
+ (t
+ curie))))
(scope (get-item :SCOPE jtm-list))
(type (get-item :TYPE jtm-list))
(value (get-item :VALUE jtm-list))
@@ -456,7 +509,7 @@
(error (make-condition 'JTM-error :message (format nil "From import-occurrence-from-jtm-list(): 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*)
+ :datatype datatype
:charvalue value
:themes (get-items-from-jtm-references
scope :revision revision :prefixes prefixes)
@@ -491,7 +544,15 @@
(let* ((iis (import-identifiers-from-jtm-strings
(get-item :ITEM--IDENTIFIERS jtm-list)
:prefixes prefixes))
- (datatype (get-item :DATATYPE jtm-list))
+ (datatype
+ (let ((curie (jtm::get-item :DATATYPE jtm-list)))
+ (cond ((null curie)
+ constants:*xml-string*)
+ ((and (tools:string-starts-with curie "[")
+ (tools:string-ends-with curie "]"))
+ (jtm::compute-uri-from-jtm-identifier curie prefixes))
+ (t
+ curie))))
(value (get-item :VALUE jtm-list))
(reifier (get-item :REIFIER jtm-list))
(parent-references (get-item :PARENT jtm-list))
Modified: trunk/src/json/JTM/jtm_tools.lisp
==============================================================================
--- trunk/src/json/JTM/jtm_tools.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/json/JTM/jtm_tools.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -11,6 +11,7 @@
(:use :cl :json :datamodel :base-tools :isidorus-threading
:constants :exceptions)
(:export :import-from-jtm
+ :import-construct-from-jtm-decoded-list
:import-construct-from-jtm-string
:export-as-jtm
:export-as-jtm-string
Modified: trunk/src/model/changes.lisp
==============================================================================
--- trunk/src/model/changes.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/model/changes.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -422,7 +422,7 @@
(defun create-latest-fragment-of-topic (topic-or-psi)
"Returns the latest fragment of the passed topic-psi"
- (declare (type (or TopicC String) topic-or-psi))
+ (declare (type (or String TopicC) topic-or-psi))
(let ((topic (if (stringp topic-or-psi)
(get-latest-topic-by-psi topic-or-psi)
topic-or-psi)))
Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/rest_interface/rest-interface.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -32,6 +32,7 @@
:start-json-engine
:start-atom-engine
:start-admin-server
+ :start-gdl-engine
:shutdown-json-engine
:shutdown-atom-engine
:*admin-local-backup*
@@ -43,6 +44,8 @@
:*remote-backup-remote-address*
:*local-backup-remote-address*
:*shutdown-remote-address*
+ :set-up-json-interface
+ :set-up-gdl-interface
:*json-get-prefix*
:*get-rdf-prefix*
:*json-commit-url*
@@ -61,9 +64,19 @@
:*xtm-commit-prefix*
:*ready-to-die*
:die-when-finished
- :*sparql-url*
:*use-http-authentication*
- :*users*))
+ :*users*
+ :*sparql-url*
+ :*gdl-get-fragment*
+ :*gdl-get-schema*
+ :*gdl-commit-fragment*
+ :*gdl-delete-fragment*
+ :*gdl-host-address-hash-object*
+ :*gdl-host-address-environment*
+ :*gdl-base-path*
+ :*gdl-host-file*
+ :*gdl-tm-id*
+ :*gdl-sparql*))
(in-package :rest-interface)
@@ -84,6 +97,7 @@
(defvar *json-server-acceptor* nil)
+(defvar *gdl-server-acceptor* nil)
(defvar *atom-server-acceptor* nil)
(defvar *admin-server-acceptor* nil)
(defvar *admin-host-name* "127.0.0.1")
@@ -115,6 +129,25 @@
(setf *admin-server-acceptor* nil))
+(defun start-gdl-engine (repository-path &key
+ (host-name "localhost") (port 8018))
+ "Starts the Topic Maps engine with a given port and address,
+ so the engine can serve and consume gdl-fragments for the
+ gdl-frontend anaToMia."
+ (when *gdl-server-acceptor*
+ (error "The gdl-server is already running"))
+ (setf hunchentoot:*show-lisp-errors-p* t) ;for now
+ (setf hunchentoot:*hunchentoot-default-external-format*
+ (flex:make-external-format :utf-8 :eol-style :lf))
+ (open-tm-store repository-path)
+ (set-up-gdl-interface)
+ (setf *gdl-server-acceptor*
+ (make-instance 'hunchentoot:acceptor :address host-name :port port))
+ (setf hunchentoot:*lisp-errors-log-level* :info)
+ (setf hunchentoot:*message-log-pathname* "./gdl-hunchentoot-errors.log")
+ (hunchentoot:start *gdl-server-acceptor*))
+
+
(defun start-json-engine (repository-path &key
(host-name "localhost") (port 8000))
"Start the Topic Maps Engine on a given port, assuming a given
Copied: trunk/src/rest_interface/set-up-gdl-interface.lisp (from r976, branches/gdl-frontend/src/rest_interface/set-up-gdl-interface.lisp)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/src/rest_interface/set-up-gdl-interface.lisp Mon Sep 26 04:56:25 2011 (r977, copy of r976, branches/gdl-frontend/src/rest_interface/set-up-gdl-interface.lisp)
@@ -0,0 +1,250 @@
+;;+-----------------------------------------------------------------------------
+;;+ Isidorus
+;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
+;;+
+;;+ Isidorus is freely distributable under the LLGPL license.
+;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
+;;+ trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+(in-package :rest-interface)
+
+(defparameter *gdl-get-fragment* "/gdl/fragment/(.+)$")
+(defparameter *gdl-get-schema* "/gdl/schema/?$")
+(defparameter *gdl-commit-fragment* "/gdl/commit/?")
+(defparameter *gdl-delete-fragment* "/gdl/delete/?")
+(defparameter *gdl-host-address-hash-object* "/hash-object")
+(defparameter *gdl-host-address-environment* "/environment")
+(defparameter *gdl-base-path* "anaToMia/hosted_files/")
+(defparameter *gdl-host-file* (concat *gdl-base-path* "GDL_Widgets.html"))
+(defparameter *gdl-tm-id* "http://textgrid.org/serviceregistry/gdl-frontend/gdl-tm")
+(defparameter *gdl-sparql* "/gdl/tm-sparql/?$")
+
+
+(defun set-up-gdl-interface (&key (get-fragment *gdl-get-fragment*)
+ (get-schema *gdl-get-schema*)
+ (commit-fragment *gdl-commit-fragment*)
+ (delete-fragment *gdl-delete-fragment*)
+ (gdl-sparql *gdl-sparql*)
+ (base-path *gdl-base-path*)
+ (host-address-hash-object *gdl-host-address-hash-object*)
+ (host-address-environment *gdl-host-address-environment*)
+ (host-file *gdl-host-file*))
+ (declare (String get-fragment get-schema commit-fragment
+ delete-fragment host-address-hash-object
+ host-address-environment host-file))
+
+ ;(init-cache nil)
+ ;(format t "~%")
+ (init-fragments nil)
+
+ ;; registers the http-code 500 for an internal server error to the standard
+ ;; return codes. so there won't be attached a hunchentoot default message,
+ ;; this is necessary to be able to send error messages in an individual way/syntax
+ ;; e.g. a json error-message.
+ (push hunchentoot:+http-internal-server-error+ hunchentoot:*approved-return-codes*)
+
+ (init-hosted-files :host-address-hash-object host-address-hash-object
+ :host-address-environment host-address-environment
+ :host-file host-file :base-path base-path)
+
+ (push
+ (create-regex-dispatcher get-fragment #'return-json-fragment-handler)
+ hunchentoot:*dispatch-table*)
+
+ (push
+ (create-regex-dispatcher get-schema #'return-gdl-schema-handler)
+ hunchentoot:*dispatch-table*)
+
+ (push
+ (create-regex-dispatcher commit-fragment #'commit-fragment-handler)
+ hunchentoot:*dispatch-table*)
+
+ (push
+ (create-regex-dispatcher delete-fragment #'delete-handler)
+ hunchentoot:*dispatch-table*)
+
+ (push
+ (create-regex-dispatcher gdl-sparql #'gdl-sparql-handler)
+ hunchentoot:*dispatch-table*))
+
+
+(defun init-hosted-files (&key (host-address-hash-object *gdl-host-address-hash-object*)
+ (host-address-environment *gdl-host-address-environment*)
+ (host-file *gdl-host-file*)
+ (base-path *gdl-base-path*))
+ "Adds handlers for the css, html and js files needed by the frontend."
+ (declare (String host-address-hash-object host-address-environment
+ host-file base-path))
+ ;; add the actual html file
+ (let ((full-host-path
+ (concat (namestring
+ (asdf:component-pathname constants:*isidorus-system*))
+ host-file))
+ (absolute-base-path
+ (concat
+ (namestring
+ (asdf:component-pathname constants:*isidorus-system*))
+ base-path)))
+ (push
+ (create-static-file-dispatcher-and-handler
+ host-address-hash-object full-host-path "text/html")
+ hunchentoot:*dispatch-table*)
+ (push
+ (create-static-file-dispatcher-and-handler
+ host-address-environment full-host-path "text/html")
+ hunchentoot:*dispatch-table*)
+ ; add all additional files
+ (let ((absolute-base-path-len (length absolute-base-path)))
+ (com.gigamonkeys.pathnames:walk-directory
+ "anaToMia/hosted_files"
+ (lambda(item)
+ (unless (or (search "/.svn/" (namestring item) :test #'string=)
+ (string= full-host-path (namestring item)))
+ (let* ((rel-addr (subseq (namestring item) absolute-base-path-len))
+ (content-type (generate-content-type (file-namestring item)))
+ (rel-uri (concat "/" rel-addr)))
+ (push
+ (create-static-file-dispatcher-and-handler
+ rel-uri item content-type)
+ hunchentoot:*dispatch-table*))))))))
+
+
+(defun generate-content-type(file-name)
+ "Returns a mime-type that corresponds to the passed
+ file-ending, note currently onle a fey types are supported!"
+ (declare (String file-name))
+ (cond ((string-ends-with file-name "png" :ignore-case t)
+ "image/png")
+ ((string-ends-with file-name "html" :ignore-case t)
+ "text/html")
+ ((string-ends-with file-name "js" :ignore-case t)
+ "application/json")
+ ((string-ends-with file-name "css" :ignore-case t)
+ "text/css")
+ ((string-ends-with file-name "gif" :ignore-case t)
+ "image/gif")
+ (t
+ "text/plain")))
+
+
+(defun delete-handler()
+ "marks the corresponding construct(s) as deleted"
+ (let ((http-method (hunchentoot:request-method*)))
+ (if (or (eq http-method :DELETE)
+ (eq http-method :POST))
+ (let ((external-format
+ (flexi-streams:make-external-format :UTF-8 :eol-style :LF)))
+ (let ((json-data
+ (hunchentoot:raw-post-data :external-format external-format
+ :force-text t)))
+ (with-writer-lock
+ (let* ((rev (d:get-revision))
+ (result (jtm-delete-interface:mark-as-deleted-from-jtm
+ json-data :revision rev)))
+ (let ((tops
+ (remove-null
+ (cond ((or (typep result 'OccurrenceC)
+ (typep result 'NameC))
+ (let ((top (parent result :revision (1- rev))))
+ (when top (list top))))
+ ((typep result 'VariantC)
+ (let ((name (parent result :revision (1- rev))))
+ (when name
+ (let ((top (parent name :revision (1- rev))))
+ (when top (list top))))))
+ ((typep result 'AssociationC)
+ (map 'list (lambda(role)
+ (player role :revision (1- rev)))
+ (roles result :revision (1- rev))))
+ ((typep result 'TopicC)
+ (let ((assocs
+ (remove-null
+ (map 'list (lambda(role)
+ (parent role :revision (1- rev)))
+ (player-in-roles result :revision (1- rev)))))
+ (frags
+ (elephant:get-instances-by-value
+ 'd:FragmentC 'd:topic result)))
+ (map nil #'elephant:drop-instance frags)
+ (loop for assoc in assocs
+ append (map 'list (lambda(role)
+ (player role :revision (1- rev)))
+ (roles assoc :revision (1- rev))))))))))
+ (map nil (lambda(top)
+ (let ((frags
+ (elephant:get-instances-by-value 'd:FragmentC 'd:topic top)))
+ (map nil #'elephant:drop-instance frags))
+ (create-latest-fragment-of-topic top))
+ (if (typep result 'd:TopicC)
+ (delete result tops)
+ tops)))
+ (unless result
+ (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
+ (format nil "object not found"))))))
+ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
+
+
+(defun commit-fragment-handler ()
+ "handles commits in the JTM 1.1 format."
+ (let ((http-method (hunchentoot:request-method*)))
+ (if (or (eq http-method :PUT)
+ (eq http-method :POST))
+ (let ((external-format
+ (flexi-streams:make-external-format :UTF-8 :eol-style :LF)))
+ (let ((json-data
+ (hunchentoot:raw-post-data :external-format external-format
+ :force-text t)))
+ (with-writer-lock
+ (jtm-importer:import-construct-from-jtm-string
+ json-data :revision (get-revision) :tm-id *gdl-tm-id*
+ :create-fragments t))))
+ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
+
+
+(defun return-gdl-schema-handler()
+ "Currently the entore topic map is returned.
+ To emerge the efficiency it will be necessary
+ to structure the data as GDL-Fragments, so each view or schema
+ can be served separately."
+ (let ((http-method (hunchentoot:request-method*)))
+ (if (eq http-method :GET)
+ (progn (setf (hunchentoot:content-type*) "application/json")
+ (jtm-exporter:export-as-jtm-string :revision 0))
+ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
+
+
+(defun return-json-fragment-handler(&optional psi)
+ "returns the json-fragmen belonging to the psi passed by the parameter psi"
+ (assert psi)
+ (let ((http-method (hunchentoot:request-method*)))
+ (if (eq http-method :GET)
+ (let ((identifier (hunchentoot:url-decode psi)))
+ (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
+ (let ((fragment
+ (with-reader-lock
+ (get-latest-fragment-of-topic identifier))))
+ (if fragment
+ (with-reader-lock
+ (jtm-exporter:export-construct-as-jtm-string
+ fragment :revision 0))
+ (progn
+ (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
+ (setf (hunchentoot:content-type*) "text")
+ (format nil "Topic \"~a\" not found" psi)))))
+ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
+
+
+(defun gdl-sparql-handler(&optional param)
+ "Returns a JSON object representing a SPARQL response."
+ (declare (Ignorable param))
+ (if (eql (hunchentoot:request-method*) :POST)
+ (let ((external-format (flexi-streams:make-external-format
+ :UTF-8 :eol-style :LF)))
+ (let ((sparql-request (hunchentoot:raw-post-data
+ :external-format external-format
+ :force-text t)))
+ (export-construct-as-isidorus-json-string
+ (make-instance 'SPARQL-Query :query sparql-request
+ :revision 0))))
+ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)))
\ No newline at end of file
Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/rest_interface/set-up-json-interface.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -35,6 +35,12 @@
is required.")
+(defparameter *cache-initialised* nil "determines wheter the cache has been
+ already set or not")
+
+(defparameter *fragments-initialised* nil "determines wheter the fragments has
+ been already initialised or not.")
+
;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi>
(defparameter *json-get-prefix* "/json/get/(.+)$")
;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi>
@@ -108,9 +114,9 @@
and also registers a file-hanlder to the html-user-interface"
;initializes cache and fragments
- (init-cache)
+ (init-cache nil)
(format t "~%")
- (init-fragments)
+ (init-fragments nil)
;; registers the http-code 500 for an internal server error to the standard
;; return codes. so there won't be attached a hunchentoot default message,
@@ -148,8 +154,7 @@
(script-url (getf (elt files-and-urls idx) :url)))
(push
(create-static-file-dispatcher-and-handler script-url script-path)
- hunchentoot:*dispatch-table*))))
-
+ hunchentoot:*dispatch-table*))))
;; === rest interface ========================================================
(push
@@ -700,7 +705,6 @@
(setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
-
(defun update-fragments-after-delete(deleted-topic delete-revision)
"Updates all fragments of topics that directly and indireclty
related to the delete-topic."
@@ -844,7 +848,7 @@
files-and-urls)))
-(defun init-cache()
+(defun init-cache(force-init)
"Initializes the type and instance cache-tables with all valid types/instances"
(with-writer-lock
(setf *type-table* nil)
@@ -880,15 +884,15 @@
(handler-case (progn
(json-tmcl::topictype-p
topic-instance topictype topictype-constraint nil 0)
- (push (elephant::oid topic-instance) *type-table*))
+ (pushnew (elephant::oid topic-instance) *type-table*))
(condition () nil)))
(handler-case (progn
(json-tmcl::valid-instance-p topic-instance nil nil 0)
- (push (elephant::oid topic-instance) *instance-table*))
+ (pushnew (elephant::oid topic-instance) *instance-table*))
(condition () nil)))
-(defun init-fragments ()
+(defun init-fragments (force-init)
"Creates fragments of all topics that have a PSI."
(format t "creating fragments: ")
(map
Modified: trunk/src/xml/xtm/exporter.lisp
==============================================================================
--- trunk/src/xml/xtm/exporter.lisp Mon Sep 26 02:48:59 2011 (r976)
+++ trunk/src/xml/xtm/exporter.lisp Mon Sep 26 04:56:25 2011 (r977)
@@ -16,41 +16,33 @@
(let ((instance-topic
(get-item-by-psi *instance-psi* :revision 0))
(type-topic
- (get-item-by-psi *type-psi* :revision 0)))
- (cond ((and (not (and instance-topic type-topic))
- (elephant:get-instances-by-class 'TopicMapC))
- (error (make-condition
- 'missing-reference-error
- :message
- (format nil "Could not resolvethe topics: ~a and ~a~%"
- *instance-psi* *type-psi*))))
- ((not (and instance-topic type-topic))
- nil)
- (t
- (loop for item in (d:get-all-associations revision)
- when (or (/= (length (roles item :revision revision)) 2)
- (and
- (= (length (roles item :revision revision)) 2)
- (not
- (and
- (or
- (eq instance-topic
- (instance-of (first (roles item
- :revision revision))
- :revision revision))
- (eq instance-topic
- (instance-of (second (roles item
- :revision revision))
- :revision revision)))
- (or (eq type-topic
- (instance-of (first (roles item
- :revision revision))
- :revision revision))
- (eq type-topic
- (instance-of (second (roles item
- :revision revision))
- :revision revision)))))))
- collect item)))))
+ (identified-construct
+ (elephant:get-instance-by-value 'PersistentIdC 'uri *type-psi*))))
+ (loop for item in (d:get-all-associations revision)
+ when (let ((assoc-roles (length (roles item :revision revision))))
+ (or (/= assoc-roles 2)
+ (and (= assoc-roles 2)
+ (not (and (or (eq instance-topic
+ (instance-of
+ (first (roles item
+ :revision revision))
+ :revision revision))
+ (eq instance-topic
+ (instance-of
+ (second (roles item
+ :revision revision))
+ :revision revision)))
+ (or (eq type-topic
+ (instance-of
+ (first (roles item
+ :revision revision))
+ :revision revision))
+ (eq type-topic
+ (instance-of
+ (second (roles item
+ :revision revision))
+ :revision revision))))))))
+ collect item)))
(defmacro with-xtm2.0 ((tm revision) &body body)
@@ -91,10 +83,11 @@
(if ,tm
(union
(filter-type-instance-topics (d:topics ,tm) tm :revision revision)
- (d:associations ,tm))
+ (list-extern-associations :revision revision))
(union
(elephant:get-instances-by-class 'd:TopicC)
- (list-extern-associations :revision revision)))))))
+ (d:associations ,tm)))))))
+
(defun export-as-xtm (xtm-path &key
More information about the Isidorus-cvs
mailing list