isidorus-cvs July 2009

isidorus-cvs@common-lisp.net

1 participants
20 discussions

[isidorus-cvs] r92 - in trunk/src: . ajax/javascripts xml xml/rdf xml/xtm
by Lukas Giessmann 15 Jul '09

15 Jul '09

Author: lgiessmann Date: Wed Jul 15 09:05:08 2009 New Revision: 92 Log: rdf-module: restructured the xml-module -> the entire xml-module is separated into an xtm-module which contains all files that have already existed. currently there exists an rdf-module which will contain all necessary files for importing/exporting rdf-data Added: trunk/src/xml/rdf/ trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/xtm/ trunk/src/xml/xtm/core_psis.xtm (props changed) - copied unchanged from r26, /trunk/src/xml/core_psis.xtm trunk/src/xml/xtm/exporter.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/exporter.lisp trunk/src/xml/xtm/exporter_xtm1.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/xtm/exporter_xtm2.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/exporter_xtm2.0.lisp trunk/src/xml/xtm/importer.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/importer.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/importer_xtm1.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/importer_xtm2.0.lisp trunk/src/xml/xtm/setup.lisp (props changed) - copied unchanged from r90, /trunk/src/xml/setup.lisp trunk/src/xml/xtm/tools.lisp (props changed) - copied unchanged from r26, /trunk/src/xml/tools.lisp Removed: trunk/src/xml/core_psis.xtm trunk/src/xml/exporter.lisp trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/exporter_xtm2.0.lisp trunk/src/xml/importer.lisp trunk/src/xml/importer_xtm1.0.lisp trunk/src/xml/importer_xtm2.0.lisp trunk/src/xml/setup.lisp trunk/src/xml/tools.lisp Modified: trunk/src/ajax/javascripts/datamodel.js trunk/src/isidorus.asd trunk/src/xml-constants.lisp Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Wed Jul 15 09:05:08 2009 @@ -1506,13 +1506,6 @@ this.__scope__.disable(); this.__value__.__frames__[0].disable(); this.__variants__.disable(); -/* - disableItemIdentity(this); - disableType(this); - disableScope(this); - disableValue(this); - disableVariants(this); - this.getFrame().setStyle(DISABLED_BACKGROUND_COLOR);*/ this.getFrame().writeAttribute({"class" : CLASSES.disabled()}); this.getFrame().writeAttribute({"title" : this.__cssTitle__}); this.hideAddButton(); @@ -1524,12 +1517,6 @@ this.__scope__.enable(); this.__value__.__frames__[0].enable(); this.__variants__.enable(); -/* - enableItemIdentity(this); - enableType(this); - enableScope(this); - enableValue(this); - enableVariants(this);*/ this.getFrame().writeAttribute({"class" : CLASSES.nameFrame()}); this.getFrame().removeAttribute("title"); checkRemoveAddButtons(this.__owner__, 1, this.__max__, this); Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Jul 15 09:05:08 2009 @@ -19,9 +19,9 @@ :licence "LGPL" :components ( (:file "constants") - (:static-file "xml/core_psis.xtm") + (:static-file "xml/xtm/core_psis.xtm") (:file "xml-constants" - :depends-on ("xml/core_psis.xtm" + :depends-on ("xml/xtm/core_psis.xtm" "constants")) (:module "model" :components ((:file "exceptions") @@ -33,22 +33,26 @@ :depends-on ("exceptions"))) :depends-on ("constants")) (:module "xml" - :components ((:file "tools") - (:file "importer" - :depends-on ("tools")) - (:file "importer_xtm2.0" - :depends-on ("importer")) - (:file "importer_xtm1.0" - :depends-on ("importer")) - (:file "setup" - :depends-on ("importer_xtm2.0" - "importer_xtm1.0")) - (:file "exporter_xtm1.0") - (:file "exporter_xtm2.0" - :depends-on ("exporter_xtm1.0")) - (:file "exporter" - :depends-on ("exporter_xtm1.0" - "exporter_xtm2.0"))) + :components ((:module "xtm" + :components ((:file "tools") + (:file "importer" + :depends-on ("tools")) + (:file "importer_xtm2.0" + :depends-on ("importer")) + (:file "importer_xtm1.0" + :depends-on ("importer")) + (:file "setup" + :depends-on ("importer_xtm2.0" + "importer_xtm1.0")) + (:file "exporter_xtm1.0") + (:file "exporter_xtm2.0" + :depends-on ("exporter_xtm1.0")) + (:file "exporter" + :depends-on ("exporter_xtm1.0" + "exporter_xtm2.0")))) + (:module "rdf" + :components ((:file "importer") + (:file "exporter")))) :depends-on ("constants" "xml-constants" "model" Modified: trunk/src/xml-constants.lisp ============================================================================== --- trunk/src/xml-constants.lisp (original) +++ trunk/src/xml-constants.lisp Wed Jul 15 09:05:08 2009 @@ -22,5 +22,5 @@ (defparameter *core_psis.xtm* (asdf:component-pathname - (asdf:find-component *isidorus-system* "xml/core_psis.xtm"))) + (asdf:find-component *isidorus-system* "xml/xtm/core_psis.xtm"))) Added: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/exporter.lisp Wed Jul 15 09:05:08 2009 @@ -0,0 +1,7 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- \ No newline at end of file Added: trunk/src/xml/rdf/importer.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/importer.lisp Wed Jul 15 09:05:08 2009 @@ -0,0 +1,7 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- \ No newline at end of file

1 0

[isidorus-cvs] r91 - in trunk/src: rest_interface unit_tests
by Lukas Giessmann 09 Jul '09

09 Jul '09

Author: lgiessmann Date: Thu Jul 9 10:21:37 2009 New Revision: 91 Log: RESTful interface: changed some procedures that creates some dispatchers for hunchentoot's dispatcherlist. There is used the function create-static-file-dispathcer-and-handler instead of using create-regex-dispather. Too much calls of create-regex-dispatcher leads to a memory-problem of the heap (on london) Modified: trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/poems.xtm Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Jul 9 10:21:37 2009 @@ -19,7 +19,7 @@ (defparameter *json-get-type-tmcl-url* "/json/tmcl/type/?$") ;the json url for getting some tmcl information of a topic treated as a type (defparameter *json-get-instance-tmcl-url* "/json/tmcl/instance/?$") ;the json url for getting some tmcl information of a topic treated as an instance (defparameter *json-get-overview* "/json/tmcl/overview/?$") ; returns a json-object representing a tree view -(defparameter *ajax-user-interface-url* "/isidorus/?$") ;the url to the user interface; +(defparameter *ajax-user-interface-url* "/isidorus") ;the url to the user interface; (defparameter *ajax-user-interface-css-prefix* "/css") ;the url to the css files of the user interface (defparameter *ajax-user-interface-css-directory-path* "ajax/css") ;the directory contains the css files (defparameter *ajax-user-interface-file-path* "ajax/isidorus.html") ;the file path to the HTML file implements the user interface @@ -52,27 +52,25 @@ (push hunchentoot:+http-internal-server-error+ hunchentoot:*approved-return-codes*) ;; === html and css files ==================================================== (push - (create-regex-dispatcher ajax-user-interface-url - #'(lambda() - (hunchentoot:handle-static-file ajax-user-interface-file-path "text/html"))) + (create-static-file-dispatcher-and-handler ajax-user-interface-url ajax-user-interface-file-path "text/html") hunchentoot:*dispatch-table*) (dolist (script-path-and-url (make-file-path-and-url ajax-user-interface-css-directory-path ajax-user-interface-css-prefix)) (let ((script-path (getf script-path-and-url :path)) (script-url (getf script-path-and-url :url))) - (push (create-regex-dispatcher script-url - #'(lambda() - (hunchentoot:handle-static-file script-path))); "text/javascript"))) - hunchentoot:*dispatch-table*))) + (push + (create-static-file-dispatcher-and-handler script-url script-path) + hunchentoot:*dispatch-table*))) + ;; === ajax frameworks and javascript files ================================== (dolist (script-path-and-url (make-file-path-and-url ajax-javascripts-directory-path ajax-javascripts-url-prefix)) (let ((script-path (getf script-path-and-url :path)) (script-url (getf script-path-and-url :url))) - (push (create-regex-dispatcher script-url - #'(lambda() - (hunchentoot:handle-static-file script-path))); "text/javascript"))) - hunchentoot:*dispatch-table*))) + (push + (create-static-file-dispatcher-and-handler script-url script-path) + hunchentoot:*dispatch-table*))) + ;; === rest interface ======================================================== (push Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Thu Jul 9 10:21:37 2009 @@ -2765,7 +2765,6 @@ <tm:association> <tm:itemIdentity href="written-by-association-shiller-resignation"/> <tm:type><tm:topicRef href="#written-by"/></tm:type> - <tm:scope><tm:topicRef href="#de"/></tm:scope> <tm:role> <tm:itemIdentity href="writer-role-schiller"/> <tm:type><tm:topicRef href="#writer"/></tm:type> @@ -2807,7 +2806,6 @@ <tm:association> <tm:type><tm:topicRef href="#written-by"/></tm:type> - <tm:scope><tm:topicRef href="#de"/></tm:scope> <tm:role> <tm:type><tm:topicRef href="#writer"/></tm:type> <tm:topicRef href="#eichendorff"/>

1 0

[isidorus-cvs] r90 - in trunk: docs src src/ajax/javascripts src/atom src/rest_interface src/threading src/unit_tests src/xml
by Lukas Giessmann 08 Jul '09

08 Jul '09

Author: lgiessmann Date: Wed Jul 8 07:02:04 2009 New Revision: 90 Log: isidorus (core): reimplemented the threading module -> all private function of hunchentoot are replaced by public functions of the package bordeaux-threads which is internally used by hunchentoot; the macors with-reader-lock and witrh-writer-lock are mostly used at the "top-layer" of all calls, e.g. RESTful-interface - with one exception the xml-im/exporter. In this module are with locks used in the main import-calls, e.g. init-isidorus, importer-xtm1.0, import-only-topics, importer, export-xtm, export-xtm-to-string and export-xtm-fragment; ajax-client: fixed a problem when creating a associaitons in the section "create topics" Added: trunk/src/unit_tests/threading_test.lisp Modified: trunk/docs/xtm_json.txt trunk/src/ajax/javascripts/create.js trunk/src/ajax/javascripts/home.js trunk/src/atom/atom.lisp trunk/src/atom/fragments.lisp trunk/src/isidorus.asd trunk/src/rest_interface/publish_feeds.lisp trunk/src/rest_interface/read.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/threading/reader-writer.lisp trunk/src/xml/exporter.lisp trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/exporter_xtm2.0.lisp trunk/src/xml/importer.lisp trunk/src/xml/importer_xtm1.0.lisp trunk/src/xml/importer_xtm2.0.lisp trunk/src/xml/setup.lisp Modified: trunk/docs/xtm_json.txt ============================================================================== --- trunk/docs/xtm_json.txt (original) +++ trunk/docs/xtm_json.txt Wed Jul 8 07:02:04 2009 @@ -390,7 +390,7 @@ //+----------------------------------------------------------------------------- -//+ associationConstraint +//+ associationConstraints //+ The associationConstraint describes how an association of a given type //+ has to be defined. //+ associationRoleTypeConstraint constains all available roletypes for this @@ -441,5 +441,5 @@ //+----------------------------------------------------------------------------- { "topicConstraints" : <topicConstraint>, - "associationsConstraints" : [ <associationConstraint>, <...> ] + "associationsConstraints" : [ <associationConstraints>, <...> ] } Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Wed Jul 8 07:02:04 2009 @@ -145,10 +145,11 @@ var aStubs = associations.getReferencedTopics(); if(aStubs && aStubs.length !== 0){ aStubs = aStubs.without(CURRENT_TOPIC).uniq(); - for(var i = 0; i !== ePsis.length; ++i) aStubs = aStubs.without(ePsis[i]); + for(var i = 0; ePsis && i !== ePsis.length; ++i) aStubs = aStubs.without(ePsis[i]); } referencedTopics = referencedTopics.concat(aStubs); } + function onSuccessHandler(topicStubs){ var tsStr = "null"; if(topicStubs && topicStubs.length !== 0){ Modified: trunk/src/ajax/javascripts/home.js ============================================================================== --- trunk/src/ajax/javascripts/home.js (original) +++ trunk/src/ajax/javascripts/home.js Wed Jul 8 07:02:04 2009 @@ -13,7 +13,7 @@ function makeHome() { var content = new Element("div", {"class" : CLASSES.content()}); - var header = new Element("h1").update("Topic Map Overview"); + var header = new Element("h1").update("Topic Maps Overview"); content.insert({"bottom" : header}); $(CLASSES.subPage()).insert({"bottom" : content}); Modified: trunk/src/atom/atom.lisp ============================================================================== --- trunk/src/atom/atom.lisp (original) +++ trunk/src/atom/atom.lisp Wed Jul 8 07:02:04 2009 @@ -8,7 +8,7 @@ (defpackage :atom - (:use :cl :cxml :constants :xml-tools :datamodel :drakma) + (:use :cl :cxml :constants :xml-tools :datamodel :drakma :isidorus-threading) (:export :collection-feed :defsite :dependency Modified: trunk/src/atom/fragments.lisp ============================================================================== --- trunk/src/atom/fragments.lisp (original) +++ trunk/src/atom/fragments.lisp Wed Jul 8 07:02:04 2009 @@ -35,23 +35,24 @@ "Unlike for the other feed types, entries can be calculated" (remove nil - (loop for fragment in - (mapcan #'d:get-fragments (rest (d:get-all-revisions))) - collect - (let - ((tm (d:get-item-by-item-identifier (tm-id feed) :revision 0)) - (xtm-link (format nil "~a/~a" - (link feed) (d:unique-id fragment))) - (psi (d:uri (first (d:psis (d:topic fragment)))))) - (when (d:in-topicmap tm (d:topic fragment)) - (make-instance 'fragment-entry - :id xtm-link - :title psi - :psi psi - :path (format nil "~a/~a" (path feed) (d:unique-id fragment)) - :updated (datetime-in-iso-format (d:revision fragment)) - :link xtm-link - :summary (format nil "Fragment for topic ~a" psi))))))) + (with-writer-lock + (loop for fragment in + (mapcan #'d:get-fragments (rest (d:get-all-revisions))) + collect + (let + ((tm (d:get-item-by-item-identifier (tm-id feed) :revision 0)) + (xtm-link (format nil "~a/~a" + (link feed) (d:unique-id fragment))) + (psi (d:uri (first (d:psis (d:topic fragment)))))) + (when (d:in-topicmap tm (d:topic fragment)) + (make-instance 'fragment-entry + :id xtm-link + :title psi + :psi psi + :path (format nil "~a/~a" (path feed) (d:unique-id fragment)) + :updated (datetime-in-iso-format (d:revision fragment)) + :link xtm-link + :summary (format nil "Fragment for topic ~a" psi)))))))) ;; (defun build-fragments-feed (tm-id) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Jul 8 07:02:04 2009 @@ -51,7 +51,8 @@ "exporter_xtm2.0"))) :depends-on ("constants" "xml-constants" - "model")) + "model" + "threading")) (:module "atom" :components ((:file "atom") ;; (:file "configuration" @@ -66,7 +67,9 @@ :depends-on ("fragments" "snapshots")) (:file "confreader" :depends-on ("collection" "fragments" "snapshots"))) - :depends-on ("model" "xml")) + :depends-on ("model" + "xml" + "threading")) (:module "rest_interface" :components ((:file "rest-interface") (:file "publish_feeds" @@ -78,7 +81,8 @@ :depends-on ("model" "atom" "xml" - "json")) + "json" + "threading")) (:module "unit_tests" :components ((:static-file "dangling_topicref.xtm") (:static-file "inconsistent.xtm") @@ -119,12 +123,14 @@ (:file "atom_test" :depends-on ("fixtures")) (:file "json_test" - :depends-on ("fixtures"))) + :depends-on ("fixtures")) + (:file "threading_test")) :depends-on ("atom" "constants" "model" "xml" - "json")) + "json" + "threading")) (:module "json" :components ((:file "json_exporter") (:file "json_importer") @@ -133,7 +139,8 @@ (:file "json_tmcl_constants") (:file "json_tmcl" :depends-on ("json_tmcl_validation"))) - :depends-on ("model" "xml")) + :depends-on ("model" + "xml")) (:module "ajax" :components ((:static-file "isidorus.html") (:module "javascripts" @@ -158,9 +165,8 @@ :components ((:static-file "home.css") (:static-file "navi.css") (:static-file "main.css"))))) - ) - ;;(:module "threading" - ;; :components ((:file "reader-writer")))) + (:module "threading" + :components ((:file "reader-writer")))) :depends-on (:cxml :drakma :elephant Modified: trunk/src/rest_interface/publish_feeds.lisp ============================================================================== --- trunk/src/rest_interface/publish_feeds.lisp (original) +++ trunk/src/rest_interface/publish_feeds.lisp Wed Jul 8 07:02:04 2009 @@ -56,7 +56,8 @@ (setf (hunchentoot:content-type*) "application/x-tm+xml;version=1.0; charset=utf-8") (let ((fragment - (d:get-fragment (parse-integer unique-id)))) + (with-reader-lock + (d:get-fragment (parse-integer unique-id))))) (if fragment (exporter:export-xtm-fragment fragment :xtm-format '1.0) (format nil "<t:topicMap xmlns:t=\"http://www.topicmaps.org/xtm/1.0/\" xmlns:xlink=\"http://www.w3.org/1999/xlink\"/>"))))) Modified: trunk/src/rest_interface/read.lisp ============================================================================== --- trunk/src/rest_interface/read.lisp (original) +++ trunk/src/rest_interface/read.lisp Wed Jul 8 07:02:04 2009 @@ -62,14 +62,14 @@ (revision (d:get-revision))) (loop for entry in (slot-value feed 'atom:entries) do (let - ((top (d:get-item-by-psi (psi entry) :revision revision)) + ((top (d:get-item-by-psi (psi entry) :revision revision)) (xtm-id (atom:id entry)) (source-locator (source-locator-prefix feed))) ;check if xtm-id has already been imported or if the entry is older ;than the snapshot feed. If so, don't do it again (unless (or (xtm-id-p xtm-id) (string> (atom:updated entry) (atom:updated imported-snapshot-entry))) (when top - (mark-as-deleted top :source-locator source-locator :revision revision)) + (mark-as-deleted top :source-locator source-locator :revision revision)) ;(format t "Fragment feed: ~a~&" (link entry)) (importer-xtm1.0 (dom:document-element @@ -79,9 +79,9 @@ ;locator + a suitable internal id as an identifier to all ;characteristics and associations that don't already have ;one and then reuse it next time - (add-source-locator - (d:get-item-by-psi (psi entry) :revision revision) ;works even if the topic is only created during import - :source-locator source-locator :revision revision)))))) + (add-source-locator + (d:get-item-by-psi (psi entry) :revision revision) ;works even if the topic is only created during import + :source-locator source-locator :revision revision)))))) (defun string-max (string-list &optional (max nil)) (cond @@ -172,9 +172,10 @@ (get-attribute snapshot-feed-link-elem "href") :tm-id feed-url))) (assert imported-snapshot-entry) - (import-fragments-feed - (get-attribute fragment-feed-link-elem "href") - imported-snapshot-entry :tm-id feed-url)))) + (with-writer-lock + (import-fragments-feed + (get-attribute fragment-feed-link-elem "href") + imported-snapshot-entry :tm-id feed-url))))) \ No newline at end of file Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Wed Jul 8 07:02:04 2009 @@ -17,7 +17,8 @@ :xml-tools :xml-importer :json-exporter - :json-importer) + :json-importer + :isidorus-threading) (:export :import-fragments-feed :import-snapshots-feed :import-tm-feed @@ -56,75 +57,16 @@ (lambda () (apply page-function (coerce matched-registers 'list)))))))) -;; (defun feeds () -;; "interface funtion to the corresponding Atom method" -;; (setf (content-type) "application/atom+xml; charset=UTF-8") -;; (cxml:with-xml-output (cxml:make-string-sink :canonical t) -;; (atom:feed-to-elem atom::*tm-feed*))) - -;; (defun snapshot-feed () -;; "Interface function to the corresponding Atom method" -;; (setf (content-type) "application/atom+xml; charset=UTF-8") -;; (cxml:with-xml-output (cxml:make-string-sink :canonical t) -;; ;(atom:build-snapshot-feed))) -;; )) - -;; (defun snapshots (&optional revision) -;; "Export a snapshot by revision" -;; (assert revision) -;; (format t "in snapshots~&") -;; (setf (content-type) "application/xtm+xml; charset=utf-8") -;; (exporter:export-xtm-to-string :revision (parse-integer revision) -;; :xtm-format '1.0)) - - -;; (defun fragments (&optional unique-id) -;; "Export a fragment by its unique id" -;; (assert unique-id) -;; (setf (content-type) "application/xtm+xml; charset=utf-8") -;; (let -;; ((fragment -;; (d:get-fragment (parse-integer unique-id)))) -;; (if fragment -;; (exporter:export-xtm-fragment fragment :xtm-format '1.0) -;; (format nil "<t:topicMap xmlns:t=\"http://www.topicmaps.org/xtm/1.0/\" xmlns:xlink=\"http://www.w3.org/1999/xlink\"/>")))) - - -;; (push -;; (create-regex-dispatcher "/feeds/?$" #'feeds) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/feeds/testtm/?$" #'tm-feed) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/snapshots/$" #'snapshot-feed) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/snapshots/([0-9]+)$" #'snapshots) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/fragments/?$" #'fragments-feed) -;; hunchentoot:*dispatch-table*) - -;; (push -;; (create-regex-dispatcher "/testtm/fragments/([0-9]+)$" #'fragments) -;; hunchentoot:*dispatch-table*) - - (defvar *server-acceptor* nil) + (defun start-tm-engine (repository-path &key (conffile "atom/conf.lisp") (host-name "localhost") (port 8000)) "Start the Topic Map Engine on a given port, assuming a given hostname. Use the repository under repository-path" (when *server-acceptor* (error "Ther server is already running")) (setf hunchentoot:*show-lisp-errors-p* t) ;for now - ;(setf hunchentoot:*show-lisp-backtraces-p* t) ;hunchentoot 0.15.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)) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Wed Jul 8 07:02:04 2009 @@ -117,7 +117,9 @@ "Returns all topic-psi that are valid types -> so they have to be valid to the topictype-constraint (if it exists) and the can't be abstract." (declare (ignorable param)) - (handler-case (let ((topic-types (json-tmcl::return-all-tmcl-types))) + (handler-case (let ((topic-types + (with-reader-lock + (json-tmcl::return-all-tmcl-types)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -133,7 +135,9 @@ The validity is only oriented on the typing of topics, e.g. type-instance or supertype-subtype." (declare (ignorable param)) - (handler-case (let ((topic-instances (json-tmcl::return-all-tmcl-instances))) + (handler-case (let ((topic-instances + (with-reader-lock + (json-tmcl::return-all-tmcl-instances)))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (json:encode-json-to-string (map 'list #'(lambda(y) @@ -152,7 +156,8 @@ (let ((topic (d:get-item-by-psi psi))) (if topic (let ((topic-json - (handler-case (json-exporter::to-json-topicStub-string topic) + (handler-case (with-reader-lock + (json-exporter::to-json-topicStub-string topic)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -176,7 +181,8 @@ (handler-case (let ((psis (json:decode-json-from-string json-data))) (let ((tmcl - (json-tmcl:get-constraints-of-fragment psis :treat-as treat-as))) + (with-reader-lock + (json-tmcl:get-constraints-of-fragment psis :treat-as treat-as)))) (if tmcl (progn (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 @@ -200,7 +206,8 @@ (if (eq http-method :GET) (progn (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (handler-case (get-all-topic-psis) + (handler-case (with-reader-lock + (get-all-topic-psis)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -216,9 +223,11 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (create-latest-fragment-of-topic identifier))) + (with-writer-lock + (create-latest-fragment-of-topic identifier)))) (if fragment - (handler-case (to-json-string fragment) + (handler-case (with-reader-lock + (to-json-string fragment)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) @@ -239,7 +248,8 @@ (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))) - (handler-case (json-importer:json-to-elem json-data) + (handler-case (with-writer-lock + (json-importer:json-to-elem json-data)) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) @@ -257,31 +267,33 @@ (end-idx (handler-case (parse-integer (hunchentoot:get-parameter "end")) (condition () nil)))) - (handler-case (let ((topics (elephant:get-instances-by-class 'd:TopicC))) - (let ((end - (cond - ((not end-idx) - (length topics)) - ((> end-idx (length topics)) - (length topics)) - ((< end-idx 0) - 0) - (t - end-idx)))) - (let ((start + (handler-case (with-reader-lock + (let ((topics + (elephant:get-instances-by-class 'd:TopicC))) + (let ((end (cond - ((> start-idx (length topics)) - end) - ((< start-idx 0) + ((not end-idx) + (length topics)) + ((> end-idx (length topics)) + (length topics)) + ((< end-idx 0) 0) (t - start-idx)))) - (let ((topics-in-range - (if (<= start end) - (subseq topics start end) - (reverse (subseq topics end start))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - (json-exporter:make-topic-summary topics-in-range))))) + end-idx)))) + (let ((start + (cond + ((> start-idx (length topics)) + end) + ((< start-idx 0) + 0) + (t + start-idx)))) + (let ((topics-in-range + (if (<= start end) + (subseq topics start end) + (reverse (subseq topics end start))))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + (json-exporter:make-topic-summary topics-in-range)))))) (condition (err) (progn (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) (setf (hunchentoot:content-type*) "text") @@ -292,7 +304,8 @@ "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) (handler-case (let ((json-string - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (with-reader-lock + (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 json-string) (Condition (err) (progn Modified: trunk/src/threading/reader-writer.lisp ============================================================================== --- trunk/src/threading/reader-writer.lisp (original) +++ trunk/src/threading/reader-writer.lisp Wed Jul 8 07:02:04 2009 @@ -7,66 +7,63 @@ ;;+----------------------------------------------------------------------------- -(defpackage :isidorus-reader-writer - (:use :cl :hunchentoot-mp) ;hunchentoot 0.15.7 +(defpackage :isidorus-threading + (:use :cl :bordeaux-threads) (:export :current-readers :with-reader-lock :with-writer-lock)) -(in-package :isidorus-reader-writer) - -(defvar *readerlist-mutex* (make-lock "isidorus current-readers lock")) ;hunchentoot 0.15.7 -(defvar *writer-mutex* (make-lock "isidorus writer lock")) ;hunchentoot 0.15.7 -;;(defvar *readerlist-mutex* (hunchentoot::make-lock "isidorus current-readers lock")) ;hunchentoot 1.0.0 -;;(defvar *writer-mutex* (hunchentoot::make-lock "isidorus writer lock")) ;hunchentoot 1.0.0 +(in-package :isidorus-threading) +(defvar *readerlist-lock* (make-lock "isidorus-threading: current readers lock")) +(defvar *writer-lock* (make-lock "isidorus-threading: writer lock")) (defvar *current-readers* nil) + (defun current-readers () - (let - ((result nil)) - ;;(with-lock (*readerlist-mutex*) ;hunchentoot 0.15.7 - (hunchentoot::with-lock-held (*readerlist-mutex*) ;hunchentoot 1.0.0 + "Returns a copy of the list which contains all current reader + threads, *current-readers*" + (let ((result nil)) + (with-lock-held (*readerlist-lock*) (setf result (copy-list *current-readers*))) result)) -(defun add-current-to-reader-list () - (with-lock (*writer-mutex*) ;hunchentoot 0.15.7 - (with-lock (*readerlist-mutex*) ;hunchentoot 0.15.7 - ;;(hunchentoot::with-lock-held (*writer-mutex*) ;hunchentoot 1.0.0 - ;;(hunchentoot::with-lock-held (*readerlist-mutex*) ;hunchentoot 1.0.0 - (push *current-process* *current-readers*)))) - -(defun remove-current-from-reader-list () - (with-lock (*readerlist-mutex*) ;hunchentoot 0.15.7 - ;;(hunchentoot::with-lock-held (*readerlist-mutex*) ;hunchentoot 1.0.0 + +(defun add-thread-to-reader-list () + "Adds the current thread to the reader list" + (with-lock-held (*writer-lock*) + (with-lock-held (*readerlist-lock*) + (push (current-thread) *current-readers*)))) + + +(defun remove-thread-from-reader-list () + "Removes the current threads from the reader list" + (with-lock-held (*readerlist-lock*) (setf *current-readers* - (delete *current-process* *current-readers*)))) + (delete (current-thread) *current-readers*)))) + (defmacro with-reader-lock (&body body) + "Executes the passed 'body' with the reader lock" `(progn - (add-current-to-reader-list) - (handler-case - (progn ,@body) - (condition (c) - (progn - (remove-current-from-reader-list) - (error c)))) - (remove-current-from-reader-list))) - + (add-thread-to-reader-list) + (let ((result nil)) + (handler-case + (setf result ,@body) + (condition (c) + (progn + (remove-thread-from-reader-list) + (error c)))) + (remove-thread-from-reader-list) + result))) + (defmacro with-writer-lock (&body body) - `(with-lock (*writer-mutex*) ;hunchentoot 0.15.7 - ;;`(hunchentoot::with-lock-held (*writer-mutex*) ;hunchetoot 1.0.0 + "Executes the passed body when the reader list is empty otherwise + the do macor loops in 500 ms time interval for a next chance." + `(with-lock-held (*writer-lock*) (do ((remaining-readers (current-readers) (current-readers))) - ((nullp remaining-raeders) nil) - ;; TODO: replace hunchentoot's internal function by - ;; something we are officially allowed to use. - ;; make sure the current thread sleeps for, say, 500ms. - (hunchentoot::process-allow-scheduling())) - ,@body)) - - - - \ No newline at end of file + ((null remaining-readers)) + (sleep 0.5)) + ,@body)) \ No newline at end of file Added: trunk/src/unit_tests/threading_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/threading_test.lisp Wed Jul 8 07:02:04 2009 @@ -0,0 +1,132 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(defpackage :threading-test + (:use :cl + :it.bese.FiveAM + :isidorus-threading + :bordeaux-threads) + (:export :run-threading-tests + :test-helpers + :test-with-reader-lock + :test-with-writer-lock + :threading-test)) + + +(in-package :threading-test) + + +(def-suite threading-test + :description "tests various key functions of the threading module") + +(in-suite threading-test) + +(test test-helpers + "Tests the helper functions current-readers, add-thread-to-reader-list + and remove-thread-from-reader-list" + (is-true isidorus-threading::*readerlist-lock*) + (is-true isidorus-threading::*writer-lock*) + (is-false isidorus-threading::*current-readers*) + (is-false (progn + (isidorus-threading::remove-thread-from-reader-list) + (current-readers))) + (is (= 1 (length (progn + (isidorus-threading::add-thread-to-reader-list) + (current-readers))))) + (is (eql (first (current-readers)) (current-thread))) + (is (= 1 (length isidorus-threading::*current-readers*))) + (is-true (let ((copy-of-readers + (current-readers))) + (setf copy-of-readers nil) + isidorus-threading::*current-readers*)) + (setf isidorus-threading::*current-readers* nil) + (is-false (current-readers)) + (is (= 2 (length (progn + (isidorus-threading::add-thread-to-reader-list) + (isidorus-threading::add-thread-to-reader-list) + (isidorus-threading::current-readers))))) + (is (= 1 (progn + (isidorus-threading::remove-thread-from-reader-list) + (push t isidorus-threading::*current-readers*) + (length (current-readers))))) + (setf isidorus-threading::*current-readers* nil)) + + +(test test-with-reader-lock + "Tests the macro with-reader-lock" + (is-true isidorus-threading::*readerlist-lock*) + (is-true isidorus-threading::*writer-lock*) + (is-false isidorus-threading::*current-readers*) + (let ((thread-1 + (make-thread #'(lambda() + (with-reader-lock (sleep 3))))) + (thread-2 + (make-thread #'(lambda() + (with-reader-lock (sleep 3))))) + (thread-3 + (make-thread #'(lambda() + (with-reader-lock (sleep 3)))))) + (is (= 3 (length (current-readers)))) + (is-true (find thread-1 (current-readers))) + (is-true (find thread-2 (current-readers))) + (is-true (find thread-3 (current-readers))) + (sleep 4) + (is-false (current-readers))) + (setf isidorus-threading::*current-readers* nil) + (make-thread #'(lambda() + (with-lock-held (isidorus-threading::*readerlist-lock*) + (sleep 3)))) + (let ((start-time + (get-universal-time))) + (isidorus-threading::add-thread-to-reader-list) + (is (<= (+ 2 start-time) (get-universal-time)))) + (setf isidorus-threading::*current-readers* nil) + (let ((start-time + (get-universal-time))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (is (> (+ start-time 3) (get-universal-time))) + (is (= 2 (length (current-readers)))) + (sleep 4)) + (is-false (current-readers))) + + +(test test-with-writer-lock + "Tests the macro with-writer-lock" + (is-true isidorus-threading::*readerlist-lock*) + (is-true isidorus-threading::*writer-lock*) + (is-false isidorus-threading::*current-readers*) + (let ((start-time + (get-universal-time))) + (with-writer-lock nil) + (is (>= (+ 1 start-time) (get-universal-time)))) + (make-thread #'(lambda() + (with-reader-lock #'(lambda() + (sleep 3))))) + (let ((start-time + (get-universal-time))) + (make-thread #'(lambda() (with-writer-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (is-false (current-readers)) + (with-writer-lock nil) + (is (<= (+ 3 start-time) (get-universal-time)))) + (let ((start-time + (get-universal-time))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (make-thread #'(lambda() (with-reader-lock (sleep 3)))) + (with-writer-lock nil) + (is (<= (+ start-time 3) (get-universal-time))))) + + +(defun run-threading-tests () + "Runs all defined tests in this package" + (it.bese.fiveam:run! 'test-helpers) + (it.bese.fiveam:run! 'test-with-reader-lock) + (it.bese.fiveam:run! 'test-with-writer-lock)) \ No newline at end of file Modified: trunk/src/xml/exporter.lisp ============================================================================== --- trunk/src/xml/exporter.lisp (original) +++ trunk/src/xml/exporter.lisp Wed Jul 8 07:02:04 2009 @@ -68,44 +68,47 @@ tm-id (revision (get-revision)) (xtm-format '2.0)) - (let - ((tm - (when tm-id - (get-item-by-item-identifier tm-id :revision revision)))) - (setf *export-tm* tm) - (with-revision revision - (with-open-file (stream xtm-path :direction :output) - (cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil) - (if (eq xtm-format '2.0) - (with-xtm2.0 + (with-reader-lock + (let + ((tm + (when tm-id + (get-item-by-item-identifier tm-id :revision revision)))) + (setf *export-tm* tm) + (with-revision revision + (with-open-file (stream xtm-path :direction :output) + (cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil) + (if (eq xtm-format '2.0) + (with-xtm2.0 (export-to-elem tm #'to-elem)) - (with-xtm1.0 - (export-to-elem tm #'to-elem-xtm1.0)))))))) + (with-xtm1.0 + (export-to-elem tm #'to-elem-xtm1.0))))))))) (defun export-xtm-to-string (&key tm-id (revision (get-revision)) (xtm-format '2.0)) - (let - ((tm - (when tm-id - (get-item-by-item-identifier tm-id :revision revision)))) - (with-revision revision - (cxml:with-xml-output (cxml:make-string-sink :canonical nil) - (if (eq xtm-format '2.0) - (with-xtm2.0 - (export-to-elem tm #'to-elem)) - (with-xtm1.0 - (export-to-elem tm #'to-elem-xtm1.0))))))) + (with-reader-lock + (let + ((tm + (when tm-id + (get-item-by-item-identifier tm-id :revision revision)))) + (with-revision revision + (cxml:with-xml-output (cxml:make-string-sink :canonical nil) + (if (eq xtm-format '2.0) + (with-xtm2.0 + (export-to-elem tm #'to-elem)) + (with-xtm1.0 + (export-to-elem tm #'to-elem-xtm1.0)))))))) (defun export-xtm-fragment (fragment &key (xtm-format '2.0)) (declare (FragmentC fragment)) - (with-revision (revision fragment) - (cxml:with-xml-output (cxml:make-string-sink :canonical nil) - (if (eq xtm-format '2.0) - (with-xtm2.0 + (with-reader-lock + (with-revision (revision fragment) + (cxml:with-xml-output (cxml:make-string-sink :canonical nil) + (if (eq xtm-format '2.0) + (with-xtm2.0 (to-elem fragment)) - (with-xtm1.0 - (to-elem-xtm1.0 fragment)))))) + (with-xtm1.0 + (to-elem-xtm1.0 fragment))))))) \ No newline at end of file Modified: trunk/src/xml/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/exporter_xtm1.0.lisp Wed Jul 8 07:02:04 2009 @@ -8,7 +8,7 @@ (defpackage :exporter - (:use :cl :cxml :elephant :datamodel) + (:use :cl :cxml :elephant :datamodel :isidorus-threading) (:import-from :constants *XTM2.0-NS* *XTM1.0-NS* Modified: trunk/src/xml/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/exporter_xtm2.0.lisp Wed Jul 8 07:02:04 2009 @@ -25,18 +25,6 @@ (cxml:attribute "href" (uri psi)))) -;; (defmethod to-elem ((scope ScopeC)) -;; (cxml:with-element "t:scope" -;; (append -;; (map 'list #'ref-to-elem (themes scope))))) - - -;; (defun scopes-to-elem (scopes) -;; (when scopes -;; (cxml:with-element "t:scope" -;; (map 'list #'ref-to-elem scopes)))) - - (defmethod to-elem ((name NameC)) "name = element name { reifiable, type?, scope?, value, variant* }" Modified: trunk/src/xml/importer.lisp ============================================================================== --- trunk/src/xml/importer.lisp (original) +++ trunk/src/xml/importer.lisp Wed Jul 8 07:02:04 2009 @@ -16,7 +16,7 @@ ;; (defpackage :xml-importer - (:use :cl :cxml :elephant :datamodel) + (:use :cl :cxml :elephant :datamodel :isidorus-threading) (:import-from :constants *type-instance-psi* *type-psi* @@ -124,18 +124,19 @@ "Initiatlize the database with the stubs of the core topics + PSIs defined in the XTM 1.0 spec. This includes a topic that represents the core TM" - (with-tm (revision "core.xtm" "http://www.topicmaps.org/xtm/1.0/core.xtm") - (let - ((core-dom - (cxml:parse-file *core_psis.xtm* (cxml-dom:make-dom-builder)))) - (loop for top-elem across - (xpath-child-elems-by-qname (dom:document-element core-dom) - *xtm2.0-ns* "topic") - do - (let - ((top - (from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm"))) - (add-to-topicmap tm top)))))) + (with-writer-lock + (with-tm (revision "core.xtm" "http://www.topicmaps.org/xtm/1.0/core.xtm") + (let + ((core-dom + (cxml:parse-file *core_psis.xtm* (cxml-dom:make-dom-builder)))) + (loop for top-elem across + (xpath-child-elems-by-qname (dom:document-element core-dom) + *xtm2.0-ns* "topic") + do + (let + ((top + (from-topic-elem-to-stub top-elem revision :xtm-id "core.xtm"))) + (add-to-topicmap tm top))))))) ;TODO: replace the two importers with this macro (defmacro importer-mac Modified: trunk/src/xml/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/importer_xtm1.0.lisp (original) +++ trunk/src/xml/importer_xtm1.0.lisp Wed Jul 8 07:02:04 2009 @@ -443,22 +443,23 @@ (declare (dom:element xtm-dom)) (declare (integer revision)) (assert elephant:*store-controller*) - (with-tm (revision xtm-id tm-id) - (let - ((topic-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "topic")) - (assoc-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "association"))) - (loop for topic across topic-vector - do (from-topic-elem-to-stub-xtm1.0 topic revision - :xtm-id xtm-id)) - (loop for top-elem across topic-vector - do - (format t "t") - (merge-topic-elem-xtm1.0 top-elem revision - :tm tm - :xtm-id xtm-id)) - (loop for assoc-elem across assoc-vector - do - (format t "a") - (from-association-elem-xtm1.0 assoc-elem revision - :tm tm - :xtm-id xtm-id))))) + (with-writer-lock + (with-tm (revision xtm-id tm-id) + (let + ((topic-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "topic")) + (assoc-vector (xpath-child-elems-by-qname xtm-dom *xtm1.0-ns* "association"))) + (loop for topic across topic-vector + do (from-topic-elem-to-stub-xtm1.0 topic revision + :xtm-id xtm-id)) + (loop for top-elem across topic-vector + do + (format t "t") + (merge-topic-elem-xtm1.0 top-elem revision + :tm tm + :xtm-id xtm-id)) + (loop for assoc-elem across assoc-vector + do + (format t "a") + (from-association-elem-xtm1.0 assoc-elem revision + :tm tm + :xtm-id xtm-id)))))) Modified: trunk/src/xml/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/importer_xtm2.0.lisp (original) +++ trunk/src/xml/importer_xtm2.0.lisp Wed Jul 8 07:02:04 2009 @@ -409,20 +409,21 @@ (declare (dom:element xtm-dom)) (declare (integer revision)) ;all topics that are imported in one go share the same revision (assert elephant:*store-controller*) - (with-tm (revision xtm-id tm-id) - (let - ((topic-vector (get-topic-elems xtm-dom)) - (assoc-vector (get-association-elems xtm-dom))) - (loop for top-elem across topic-vector do - (from-topic-elem-to-stub top-elem revision - :xtm-id xtm-id)) - (loop for top-elem across topic-vector do - (format t "t") - (merge-topic-elem top-elem revision - :tm tm - :xtm-id xtm-id)) - (loop for assoc-elem across assoc-vector do - (format t "a") - (from-association-elem assoc-elem revision - :tm tm - :xtm-id xtm-id))))) + (with-writer-lock + (with-tm (revision xtm-id tm-id) + (let + ((topic-vector (get-topic-elems xtm-dom)) + (assoc-vector (get-association-elems xtm-dom))) + (loop for top-elem across topic-vector do + (from-topic-elem-to-stub top-elem revision + :xtm-id xtm-id)) + (loop for top-elem across topic-vector do + (format t "t") + (merge-topic-elem top-elem revision + :tm tm + :xtm-id xtm-id)) + (loop for assoc-elem across assoc-vector do + (format t "a") + (from-association-elem assoc-elem revision + :tm tm + :xtm-id xtm-id)))))) Modified: trunk/src/xml/setup.lisp ============================================================================== --- trunk/src/xml/setup.lisp (original) +++ trunk/src/xml/setup.lisp Wed Jul 8 07:02:04 2009 @@ -19,25 +19,26 @@ (xtm-format '2.0) (xtm-id (get-uuid))) "Imports an XTM file into an existing repository using the correct -importer for the XTM version. Does *not* close the store afterwards" + importer for the XTM version. Does *not* close the store afterwards" (declare ((or pathname string) xtm-path)) (declare ((or pathname string) repository-path)) (let ((xtm-dom (dom:document-element (cxml:parse-file - (truename xtm-path) (cxml-dom:make-dom-builder))))) + (truename xtm-path) (cxml-dom:make-dom-builder))))) (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) - ;create the topic stubs so that we can refer to them later on + ;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) - (importer xtm-dom :tm-id tm-id :xtm-id xtm-id) - (importer-xtm1.0 xtm-dom :tm-id tm-id :xtm-id xtm-id)) - (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" - (length (elephant:get-instances-by-class 'TopicC)) - (length (elephant:get-instances-by-class 'AssociationC))))) - ;(format t "#Topics in the store: ~a~%" (length (elephant:get-instances-by-class 'TopicC))))) + (importer xtm-dom :tm-id tm-id :xtm-id xtm-id) + (importer-xtm1.0 xtm-dom :tm-id tm-id :xtm-id xtm-id)) + (with-reader-lock + (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" + (length (elephant:get-instances-by-class 'TopicC)) + (length (elephant:get-instances-by-class 'AssociationC)))))) + (defun setup-repository (xtm-path repository-path &key tm-id @@ -46,11 +47,10 @@ "Initializes a repository and imports a XTM file into it" (declare ((or pathname string) xtm-path)) (declare ((or pathname string) repository-path)) - (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) (init-isidorus) (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format) (when elephant:*store-controller* - (elephant:close-store))) \ No newline at end of file + (elephant:close-store))) \ No newline at end of file

1 0

[isidorus-cvs] r89 - in trunk/src: ajax/javascripts unit_tests
by Lukas Giessmann 04 Jul '09

04 Jul '09

Author: lgiessmann Date: Sat Jul 4 11:49:18 2009 New Revision: 89 Log: ajax-client: the test-file poems.xtm was changed to a final state - there are no unused sub-types or any other senseless constructs for testing anymore Modified: trunk/src/ajax/javascripts/constants.js trunk/src/unit_tests/poems.xtm Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Sat Jul 4 11:49:18 2009 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://192.168.178.21:8000/"; //"http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Sat Jul 4 11:49:18 2009 @@ -1,76 +1,5 @@ <?xml version="1.0" encoding="UTF-8"?> <tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/"> -  - <tm:topic id="sub-written"> - <tm:subjectIdentifier href="sub-written-psi"/> - </tm:topic> - - <tm:association> - <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type> - <tm:role> - <tm:type><tm:topicRef href="#subtype"/></tm:type> - <tm:topicRef href="#sub-written"/> - </tm:role> - <tm:role> - <tm:type><tm:topicRef href="#supertype"/></tm:type> - <tm:topicRef href="#written"/> - </tm:role> - </tm:association> -  - - -  - <tm:topic id="scoped-born-in-constraint-1"> - <tm:subjectIdentifier href="http://some.where/constraint-psis/scoped-born-in-constraint-1"/> - <tm:instanceOf><tm:topicRef href="#associationtypescope-constraint"/></tm:instanceOf> - <tm:occurrence> - <tm:type><tm:topicRef href="#card-min"/></tm:type> - <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">1</tm:resourceData> - </tm:occurrence> - <tm:occurrence> - <tm:type><tm:topicRef href="#card-max"/></tm:type> - <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#unsignedInt">2</tm:resourceData> - </tm:occurrence> - </tm:topic> - - <tm:association> - <tm:type><tm:topicRef href="#applies-to"/></tm:type> - <tm:role> - <tm:type><tm:topicRef href="#constraint-role"/></tm:type> - <tm:topicRef href="#scoped-born-in-constraint-1"/> - </tm:role> - <tm:role> - <tm:type><tm:topicRef href="#associationtype-role"/></tm:type> - <tm:topicRef href="#written-by"/> - </tm:role> - </tm:association> - - <tm:association> - <tm:type><tm:topicRef href="#applies-to"/></tm:type> - <tm:role> - <tm:type><tm:topicRef href="#constraint-role"/></tm:type> - <tm:topicRef href="#scoped-born-in-constraint-1"/> - </tm:role> - <tm:role> - <tm:type><tm:topicRef href="#scopetype-role"/></tm:type> - <tm:topicRef href="#en"/> - </tm:role> - </tm:association> - - <tm:association> - <tm:type><tm:topicRef href="#applies-to"/></tm:type> - <tm:role> - <tm:type><tm:topicRef href="#constraint-role"/></tm:type> - <tm:topicRef href="#scoped-born-in-constraint-1"/> - </tm:role> - <tm:role> - <tm:type><tm:topicRef href="#scopetype-role"/></tm:type> - <tm:topicRef href="#de"/> - </tm:role> - </tm:association> -  - -    @@ -1640,45 +1569,6 @@ </tm:association> -  - <tm:topic id="sub-poem-content"> - <tm:subjectIdentifier href="http://some.where/base-psis/sub-poem-content"/> - </tm:topic> - - <tm:association> - <tm:type><tm:topicRef href="#supertype-subtype"/></tm:type> - <tm:role> - <tm:type><tm:topicRef href="#subtype"/></tm:type> - <tm:topicRef href="#sub-poem-content"/> - </tm:role> - <tm:role> - <tm:type><tm:topicRef href="#supertype"/></tm:type> - <tm:topicRef href="#poem-content"/> - </tm:role> - </tm:association> - - <tm:topic id="sub-poem-content-occurrence-datatype-constraint"> - <tm:subjectIdentifier href="http://some.where/constraint-psis/sub-poem-content-occurrence-datatype-cons…"/> - <tm:instanceOf><tm:topicRef href="#occurrencedatatype-constraint"/></tm:instanceOf> - <tm:occurrence> - <tm:type><tm:topicRef href="#datatype"/></tm:type> - <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">http://www.w3.org/2001/XMLSchema#float</tm:resourceData> - </tm:occurrence> - </tm:topic> - - <tm:association> - <tm:type><tm:topicRef href="#applies-to"/></tm:type> - <tm:role> - <tm:type><tm:topicRef href="#constraint-role"/></tm:type> - <tm:topicRef href="#sub-poem-content-occurrence-datatype-constraint"/> - </tm:role> - <tm:role> - <tm:type><tm:topicRef href="#occurrencetype-role"/></tm:type> - <tm:topicRef href="#sub-poem-content"/> - </tm:role> - </tm:association> - -  @@ -2547,7 +2437,7 @@ </tm:name> <tm:occurrence> <tm:type><tm:topicRef href="#poem-content"/></tm:type>  - <tm:scope><tm:topicRef href="#en"/></tm:scope> + <tm:scope><tm:topicRef href="#de"/></tm:scope> <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">Hat der alte Hexenmeister sich doch einmal wegbegeben! Und nun sollen seine Geister @@ -2717,7 +2607,6 @@ <tm:association> <tm:itemIdentity href="wirtten-by-zauberlehrling-goethe"/> <tm:type><tm:topicRef href="#written-by"/></tm:type> - <tm:scope><tm:topicRef href="#de"/></tm:scope> <tm:role> <tm:type><tm:topicRef href="#writer"/></tm:type> <tm:topicRef href="#goethe"/> @@ -2731,7 +2620,6 @@ <tm:association> <tm:itemIdentity href="wirtten-by-erlkoenig-goethe"/> <tm:type><tm:topicRef href="#written-by"/></tm:type> - <tm:scope><tm:topicRef href="#de"/></tm:scope> <tm:role> <tm:type><tm:topicRef href="#writer"/></tm:type> <tm:topicRef href="#goethe"/>

1 0

[isidorus-cvs] r88 - trunk/src/ajax/javascripts
by Lukas Giessmann 04 Jul '09

04 Jul '09

Author: lgiessmann Date: Sat Jul 4 11:33:48 2009 New Revision: 88 Log: ajax-client: fixed a bug under safari with the class "SelectrowC" where the default-selected-element wasn't selected. currently there will be additionally set the option selected="selected" to solve this problem Modified: trunk/src/ajax/javascripts/constants.js trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Sat Jul 4 11:33:48 2009 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = "http://192.168.178.21:8000/"; //"http://localhost:8000/"; // of the form "http://(.+)/" var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Sat Jul 4 11:33:48 2009 @@ -158,7 +158,9 @@ this.__content__ = new Element("select"); for(var i = 0; i != contents.length; ++i){ // --- the attribute value must be set for IE - this.__content__.insert({"bottom" : new Element("option", {"value" : contents[i]}).update(contents[i])}); + var opt = new Element("option", {"value" : contents[i]}).update(contents[i]); + this.__content__.insert({"bottom" : opt}); + if(i === 0) opt.writeAttribute({"selected" : "selected"}); } this.__remove__.insert({"after" : this.__content__});

1 0

[isidorus-cvs] r87 - trunk/src/ajax/javascripts
by Lukas Giessmann 04 Jul '09

04 Jul '09

Author: lgiessmann Date: Sat Jul 4 11:11:44 2009 New Revision: 87 Log: ajax-client: fixed a known problem by committing edited fragments - so there won't be requested a topicStub for current fragment's "main"-topic Modified: trunk/src/ajax/javascripts/create.js Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Sat Jul 4 11:11:44 2009 @@ -137,7 +137,17 @@ else tPsis = tPsis.toJSON() var referencedTopics = topic.getReferencedTopics(); if(associations){ - referencedTopics = referencedTopics.concat(associations.getReferencedTopics()).without(CURRENT_TOPIC).uniq(); + var ePsis = null; + if(contents && contents.topic && contents.topic.subjectIdentifiers && contents.topic.subjectIdentifiers.length !== 0){ + ePsis = contents.topic.subjectIdentifiers; + } + + var aStubs = associations.getReferencedTopics(); + if(aStubs && aStubs.length !== 0){ + aStubs = aStubs.without(CURRENT_TOPIC).uniq(); + for(var i = 0; i !== ePsis.length; ++i) aStubs = aStubs.without(ePsis[i]); + } + referencedTopics = referencedTopics.concat(aStubs); } function onSuccessHandler(topicStubs){ var tsStr = "null";

1 0

[isidorus-cvs] r86 - trunk/src/ajax/javascripts
by Lukas Giessmann 04 Jul '09

04 Jul '09

Author: lgiessmann Date: Sat Jul 4 10:36:21 2009 New Revision: 86 Log: ajax-client: fixed a problem that occurred with firefox after committing an edit or created fragment by changing the occurrent-type, so the datatyp does'nt changed to the corresponding occurrent-type Modified: trunk/src/ajax/javascripts/constants.js trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Sat Jul 4 10:36:21 2009 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = /*"http://143.93.190.237:8000/";*/ "http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Sat Jul 4 10:36:21 2009 @@ -1816,7 +1816,17 @@ var cssTitle = "No constraint found for this occurrence"; if(noConstraint === false) cssTitle = "min: " + _min + " max: " + _max + " regular expression: " + constraint.regexp; this.__cssTitle__ = cssTitle; - makeResource(this, contents, constraint, (occurrenceTypes ? occurrenceTypes[0].datatypeConstraint : null), cssTitle, {"rows" : 5, "cols" : 70}); + + var dataType = null; + if(types && types.length !== 0){ + for(var i = 0; occurrenceTypes && i !== occurrenceTypes.length; ++i){ + if(occurrenceTypes[i].occurrenceType.indexOf(types[0]) !== -1){ + dataType = occurrenceTypes[i].datatypeConstraint; + break; + } + } + } + makeResource(this, contents, constraint, dataType, cssTitle, {"rows" : 5, "cols" : 70}); this.getFrame().observe("dblclick", function(event){ dblClickHandler(owner, event); @@ -4056,7 +4066,8 @@ } if(foundIdx !== -1 && constraints[foundIdx].datatypeConstraint){ var dc = constraints[foundIdx].datatypeConstraint; - myself.__datatype__.__frames__[0].getFrame().select("input")[0].writeAttribute({"readonly" : "readonly", "value" : dc}); + myself.__datatype__.__frames__[0].getFrame().select("input")[0].writeAttribute({"readonly" : "readonly"}); + myself.__datatype__.__frames__[0].getFrame().select("input")[0].setValue(dc); } else { myself.__datatype__.__frames__[0].getFrame().select("input")[0].writeAttribute({"value" : ""});

1 0

[isidorus-cvs] r85 - trunk/src/json
by Lukas Giessmann 04 Jul '09

04 Jul '09

Author: lgiessmann Date: Sat Jul 4 06:54:10 2009 New Revision: 85 Log: json-server: fixed a bug with collecting constraint topics for a give topic-type or topic-instance Modified: trunk/src/json/json_tmcl.lisp trunk/src/json/json_tmcl_validation.lisp Modified: trunk/src/json/json_tmcl.lisp ============================================================================== --- trunk/src/json/json_tmcl.lisp (original) +++ trunk/src/json/json_tmcl.lisp Sat Jul 4 06:54:10 2009 @@ -991,8 +991,24 @@ (let ((akos-and-isas-of-this (remove-duplicates (if (eql treat-as 'type) - (topictype-p topic-instance) - (valid-instance-p topic-instance))))) + (progn + (topictype-p topic-instance) + (get-all-upper-constrainted-topics topic-instance)) + (progn + (valid-instance-p topic-instance) + (let ((topictypes + (get-direct-types-of-topic topic-instance)) + (all-constraints nil)) + (dolist (tt topictypes) + (let ((upts + (get-all-upper-constrainted-topics tt))) + (dolist (upt upts) + (pushnew upt all-constraints)))) + (remove-if #'(lambda(x) + (when (eql x topic-instance) + t)) + all-constraints))))))) + (let ((all-abstract-topictype-constraints nil) (all-exclusive-instance-constraints nil) (all-subjectidentifier-constraints nil) @@ -1068,8 +1084,9 @@ (defun get-all-constraint-topics-of-association(associationtype-topic) "Returns all constraint topics defined for associations if the passed associationtype-topic." + (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (is-type-constrained :what *associationtype-constraint-psi*)) (let ((akos-and-isas-of-this - (topictype-p associationtype-topic (get-item-by-psi *associationtype-psi*) (is-type-constrained :what *associationtype-constraint-psi*)))) + (get-all-upper-constrainted-topics associationtype-topic))) (let ((all-associationrole-constraints nil) (all-roleplayer-constraints nil) (all-otherrole-constraints nil)) Modified: trunk/src/json/json_tmcl_validation.lisp ============================================================================== --- trunk/src/json/json_tmcl_validation.lisp (original) +++ trunk/src/json/json_tmcl_validation.lisp Sat Jul 4 06:54:10 2009 @@ -420,4 +420,31 @@ (remove-if #'(lambda(x) (when (eql topictype-constraint x) t)) (get-direct-instances-of-topic topictype-constraint)))))) - ttc)))) \ No newline at end of file + ttc)))) + + +(defun list-all-supertypes (topic-instance &optional (checked-topics nil)) + "Returns all supertypes of the given topic recursively." + (let ((current-checked-topics (append checked-topics (list topic-instance))) + (akos-of-this (get-direct-supertypes-of-topic topic-instance))) + (dolist (ako-of-this akos-of-this) + (when (not (find ako-of-this current-checked-topics)) + (let ((new-checked-topics + (list-all-supertypes ako-of-this current-checked-topics))) + (dolist (new-topic new-checked-topics) + (pushnew new-topic current-checked-topics))))) + current-checked-topics)) + + +(defun get-all-upper-constrainted-topics (topic) + "Returns all topics that are supertypes or direct types + of the given topic-type. So all direct constraints of the found + topics are valid constraints for the given one." + ;; find all direct types + (let ((direct-isas-of-this + (get-direct-types-of-topic topic))) + + ;; find all supertypes (recursive -> transitive relationship + (let ((all-akos-of-this + (list-all-supertypes topic))) + (remove-duplicates (union direct-isas-of-this all-akos-of-this))))) \ No newline at end of file

1 0

[isidorus-cvs] r84 - in trunk/src: ajax/javascripts model rest_interface unit_tests
by Lukas Giessmann 03 Jul '09

03 Jul '09

Author: lgiessmann Date: Fri Jul 3 17:21:46 2009 New Revision: 84 Log: json-server: fixed a problem with requesting the latest fragment of a given topic-psi -> now there will be searched or created REALLY the LATEST fragment Modified: trunk/src/ajax/javascripts/edit.js trunk/src/ajax/javascripts/requests.js trunk/src/model/changes.lisp trunk/src/model/datamodel.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/json_test.lisp Modified: trunk/src/ajax/javascripts/edit.js ============================================================================== --- trunk/src/ajax/javascripts/edit.js (original) +++ trunk/src/ajax/javascripts/edit.js Fri Jul 3 17:21:46 2009 @@ -53,7 +53,7 @@ liTopicSelect.insert({"bottom" : err}); } else { - if(!psi || psi.strip().lenght === 0) psi = null; + if(!psi || psi.strip().length === 0) psi = null; edit = new EditC(json.flatten().sort(), innerMakeFragment, psi); liTopicSelect.insert({"bottom" : edit.getFrame()}); } Modified: trunk/src/ajax/javascripts/requests.js ============================================================================== --- trunk/src/ajax/javascripts/requests.js (original) +++ trunk/src/ajax/javascripts/requests.js Fri Jul 3 17:21:46 2009 @@ -161,7 +161,7 @@ else topicStubs.push(xhr.responseText); }, "onFailure" : function(xhr){ - alert("From getTopicStubs(): Could not equest topicStub information for \"" + xhr.request.url + "\"!!!"); + alert("From getTopicStubs(): Could not request topicStub information for \"" + xhr.request.url + "\"!!!"); onFailureHandler(); }}); } Modified: trunk/src/model/changes.lisp ============================================================================== --- trunk/src/model/changes.lisp (original) +++ trunk/src/model/changes.lisp Fri Jul 3 17:21:46 2009 @@ -270,29 +270,27 @@ (find-associations-for-topic top))) -(defun get-latest-fragment-of-topic (topic-psi) +(defun create-latest-fragment-of-topic (topic-psi) "returns the latest fragment of the passed topic-psi" (declare (string topic-psi)) - (let ((topic-psi topic-psi)) - (let ((psi - (elephant:get-instance-by-value 'PersistentIdC 'uri topic-psi))) - (when psi - (let ((topic - (identified-construct psi))) - (when topic - (loop for current-revision in (versions topic) - do (get-fragments (start-revision current-revision))) - (let ((fragments - (elephant:get-instances-by-value 'FragmentC 'topic topic))) - ;; maybe there are more fragments of this topic in different revisions, - ;; so we need to search the fragment with a certain revision - (let ((found-fragment - (if fragments - (first (sort fragments #'> :key 'revision)) - ;; if there exist a topic but always no fragment, there will be generated a new fragment of the latest version for the searched topic - (make-instance 'FragmentC - :revision (first (sort (versions topic) #'> :key 'start-revision)) - :associations (find-associations-for-topic topic) - :referenced-topics (find-referenced-topics topic) - :topic topic)))) - found-fragment)))))))) \ No newline at end of file + (let ((topic + (get-item-by-psi topic-psi))) + (when topic + (let ((start-revision + (start-revision + (find-if #'(lambda(x) + (when (= 0 (end-revision x)) + t)) + (versions topic))))) + (let ((existing-fragment + (find-if #'(lambda(x) + (when (eq topic (topic x)) + t)) + (get-fragments start-revision)))) + (if existing-fragment + existing-fragment + (make-instance 'FragmentC + :revision start-revision + :associations (find-associations-for-topic topic) + :referenced-topics (find-referenced-topics topic) + :topic topic))))))) \ No newline at end of file Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri Jul 3 17:21:46 2009 @@ -99,7 +99,7 @@ :used-as-theme :variants :xor - :get-latest-fragment-of-topic + :create-latest-fragment-of-topic :*current-xtm* ;; special variables :*TM-REVISION* Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Fri Jul 3 17:21:46 2009 @@ -216,7 +216,7 @@ (let ((identifier (string-replace psi "%23" "#"))) (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 (let ((fragment - (get-latest-fragment-of-topic identifier))) + (create-latest-fragment-of-topic identifier))) (if fragment (handler-case (to-json-string fragment) (condition (err) Modified: trunk/src/unit_tests/json_test.lisp ============================================================================== --- trunk/src/unit_tests/json_test.lisp (original) +++ trunk/src/unit_tests/json_test.lisp Fri Jul 3 17:21:46 2009 @@ -131,10 +131,10 @@ (elephant:open-store (xml-importer:get-store-spec dir)) (let ((frag-t100 - (get-latest-fragment-of-topic + (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…")) (frag-topic - (get-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#topic"))) + (create-latest-fragment-of-topic "http://www.topicmaps.org/xtm/1.0/core.xtm#topic"))) (let ((frag-t100-string (concatenate 'string "{\"topic\":{\"id\":\"" (d:topicid (d:topic frag-t100)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…"],\"instanceOfs\":[[\"http://psi.egovpt.org/types/semanticstandard\"]],\"names\":[{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100_n1\"],\"type\":null,\"scopes\":null,\"value\":\"ISO 19115\",\"variants\":[{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100_n1_v1\"],\"scopes\":[[\"http://www.topicmaps.org/xtm/1.0/core.xtm#display\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",\"value\":\"Geographic Information - Metadata\"}},{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100_n1_v2\"],\"scopes\":[[\"http://www.topicmaps.org/xtm/1.0/core.xtm#sort\"]],\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",\"value\":\"ISO-19115\"}}]}],\"occurrences\":[{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100_o1\"],\"type\":[\"http://psi.egovpt.org/types/standardHasStatus\"],\"scopes\":null,\"resourceRef\":\"http://www.budabe.de/\",\"resourceData\":null},{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100_o2\"],\"type\":[\"http://psi.egovpt.org/types/description\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#string\",\"value\":\"The ISO 19115 standard ...\"}},{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100_o3\"],\"type\":[\"http://psi.egovpt.org/types/standardValidFromDate\"],\"scopes\":null,\"resourceRef\":null,\"resourceData\":{\"datatype\":\"http://www.w3.org/2001/XMLSchema#date\",\"value\":\"2003-01-01\"}},{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t100_o4\"],\"type\":[\"http://psi.egovpt.org/types/links\"],\"scopes\":null,\"resourceRef\":\"http://www.editeur.org/standards/ISO19115.pdf\",\"resourceData\":null}]},\"topicStubs\":[{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 0)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t3a\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/semanticstandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 1)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://www.topicmaps.org/xtm/1.0/core.xtm#display\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 2)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://www.topicmaps.org/xtm/1.0/core.xtm#sort\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 3)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t51\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/standardHasStatus\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 4)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t53\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 5)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t54\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/standardValidFromDate\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 6)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t55\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/links\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 7)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/subject/GeoData\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 8)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t60\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/standardIsAboutSubject\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 9)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t61\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/SubjectRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 10)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/subject/Semantic+Description\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 11)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t64\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/serviceUsesStandard\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 12)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t63\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/ServiceRoleType\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 13)) "\",\"itemIdentities\":null,\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/service/Google+Maps\",\"http://maps.google.com\"]},{\"id\":\"" (topicid (elt (referenced-topics frag-t100) 14)) "\",\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#t62\"],\"subjectLocators\":null,\"subjectIdentifiers\":[\"http://psi.egovpt.org/types/StandardRoleType\"]}],\"associations\":[{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/StandardRoleType\"],\"topicRef\":[\"http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…"]},{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/SubjectRoleType\"],\"topicRef\":[\"http://psi.egovpt.org/subject/GeoData\"]}]},{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/standardIsAboutSubject\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/StandardRoleType\"],\"topicRef\":[\"http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…"]},{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/SubjectRoleType\"],\"topicRef\":[\"http://psi.egovpt.org/subject/Semantic+Description\"]}]},{\"itemIdentities\":[\"http://psi.egovpt.org/itemIdentifiers#assoc_7\"],\"type\":[\"http://psi.egovpt.org/types/serviceUsesStandard\"],\"scopes\":null,\"roles\":[{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/ServiceRoleType\"],\"topicRef\":[\"http://psi.egovpt.org/service/Google+Maps\",\"http://maps.google.com\"]},{\"itemIdentities\":null,\"type\":[\"http://psi.egovpt.org/types/StandardRoleType\"],\"topicRef\":[\"http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…"]}]}],\"tmIds\":[\"http://www.isidor.us/unittests/testtm\"]}")) (frag-topic-string @@ -155,7 +155,7 @@ (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj - (get-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) + (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) (to-json-string fragment-obj)))) (let ((fragment-list (json-importer::get-fragment-values-from-json-list

1 0

[isidorus-cvs] r83 - in trunk/src: ajax/javascripts json
by Lukas Giessmann 01 Jul '09

01 Jul '09

Author: lgiessmann Date: Wed Jul 1 03:32:59 2009 New Revision: 83 Log: ajax-client: fixed a bug which occured by editing existing topics with more than one PSI - if you selected the placeholder "**current-topic**" the PSIs were transformed to JSON as one long string and not as an array Modified: trunk/src/ajax/javascripts/create.js trunk/src/json/json_importer.lisp Modified: trunk/src/ajax/javascripts/create.js ============================================================================== --- trunk/src/ajax/javascripts/create.js (original) +++ trunk/src/ajax/javascripts/create.js Wed Jul 1 03:32:59 2009 @@ -133,6 +133,8 @@ // --- if the validation succeeded the fragment will be sent to the server var tPsis = topic.getContent().subjectIdentifiers; + if(!tPsis || tPsis.length === 0) tPsis = "null"; + else tPsis = tPsis.toJSON() var referencedTopics = topic.getReferencedTopics(); if(associations){ referencedTopics = referencedTopics.concat(associations.getReferencedTopics()).without(CURRENT_TOPIC).uniq(); @@ -149,7 +151,7 @@ } var jTopic = "\"topic\":" + topic.toJSON(); var jTopicStubs = "\"topicStubs\":" + tsStr; - var jAssociations = "\"associations\":" + (associations ? associations.toJSON().gsub(CURRENT_TOPIC_ESCAPED, tPsis) : "null"); + var jAssociations = "\"associations\":" + (associations ? associations.toJSON().gsub("\\[\"" + CURRENT_TOPIC_ESCAPED + "\"\\]", tPsis) : "null"); var jTmId = "\"tmIds\":" + tmId.toJSON(); var json = "{" + jTopic + "," + jTopicStubs + "," + jAssociations + "," + jTmId + "}"; commitFragment(json, function(xhr){ alert("The fragment was committed succesfully!"); }, null); Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Wed Jul 1 03:32:59 2009 @@ -217,6 +217,7 @@ 'd:PersistentIdC 'd:uri uri) return (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri uri)))) + (format t "psi: ~a~%" psi) (when psi (d:identified-construct psi))))) (unless top

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs July 2009