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