[isidorus-cvs] r90 - in trunk: docs src src/ajax/javascripts src/atom src/rest_interface src/threading src/unit_tests src/xml
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Jul 8 11:02:06 UTC 2009
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 , at 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 , at 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()))
- , at body))
-
-
-
-
\ No newline at end of file
+ ((null remaining-readers))
+ (sleep 0.5))
+ , at 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
More information about the Isidorus-cvs
mailing list