[elephant-cvs] CVS elephant/src/db-clsql
rread
rread at common-lisp.net
Wed Feb 7 22:54:13 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory clnet:/tmp/cvs-serv4302/src/db-clsql
Modified Files:
package.lisp sql-controller.lisp
Log Message:
Commiting a thread-safe version of the SQL side (but SBCL-depdent.)
--- /project/elephant/cvsroot/elephant/src/db-clsql/package.lisp 2006/11/11 18:41:11 1.1
+++ /project/elephant/cvsroot/elephant/src/db-clsql/package.lisp 2007/02/07 22:54:12 1.2
@@ -20,5 +20,8 @@
(defpackage db-clsql
(:use :common-lisp :uffi :cl-base64
- :elephant :elephant-memutil :elephant-backend))
+ :elephant :elephant-memutil :elephant-backend
+;; :elephant-utils
+ #+sbcl :sb-thread
+ ))
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/05 00:32:27 1.16
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/07 22:54:12 1.17
@@ -22,14 +22,64 @@
;; The main SQL Controller Class
;;
+;; Every actual CL-SQL connection has to be in a separate thread.
+;; My solution to this is to keep a map of threads, and reuse
+;; connections within a certain thread.
+;; This seems to be effective under SBCL; as of 06-Feb-2007 we
+;; don't necessarily have a way to do this under the other implementations
+;; (see src/utils/lock.lisp.)
+
(defclass sql-store-controller (store-controller)
- ((db :accessor controller-db :initarg :db :initform nil))
+ (
+;; (db :accessor controller-db :initarg :db :initform nil)
+ (dbcons :accessor controller-db-table :initarg :db :initform nil)
+ )
(:documentation "Class of objects responsible for the
book-keeping of holding DB handles, the cache, table
creation, counters, locks, the root (for garbage collection,)
et cetera. This is the Postgresql-specific subclass of store-controller."))
+
+;; This should be much more elegant --- but as of Feb. 6, SBCL 1.0.2 has a weird,
+;; unpleasant bug when ASDF tries to load this stuff.
+;; (defvar *thread-table-lock* nil)
+;; (defvar *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock"))
+
+(defvar *thread-table-lock* nil)
+
+(defun insure-thread-table-lock ()
+ (if (null *thread-table-lock*)
+;; nil
+;; (setq *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock"))
+ (setq *thread-table-lock* (elephant::ele-make-lock))
+ )
+)
+
+
+(defun thread-hash ()
+ (elephant::ele-thread-hash-key)
+)
+
+
+(defmethod controller-db ((sc sql-store-controller))
+ (elephant::ele-with-lock (*thread-table-lock*)
+ (let ((curcon (gethash (thread-hash) (controller-db-table sc))))
+ (if curcon
+ curcon
+ (let* ((dbtype (car (second (controller-spec sc))))
+ (con (clsql:connect (cdr (second (controller-spec sc)))
+ :database-type dbtype
+ :pool t
+ :if-exists :new)))
+ (setf (gethash (thread-hash) (controller-db-table sc))
+ con)
+ con)
+ )
+ )
+ ))
+
+
(eval-when (:compile-toplevel :load-toplevel)
(register-backend-con-init :clsql 'sql-test-and-construct))
@@ -270,15 +320,25 @@
;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem!
;; ALL OF THIS needs to be inside a transaction.
- (clsql::create-table [keyvalue]
-
- ;; This is most likely to work with any database system..
- '(
- ([clctn_id] integer :not-null)
- ([key] text :not-null)
- ([value] text)
- )
- :database con)
+ (clsql::create-sequence [serial] :database con)
+ (clsql::query
+ (format nil "create table keyvalue (
+ pk integer PRIMARY KEY DEFAULT nextval('serial'),
+ clctn_id integer NOT NULL,
+ key varchar NOT NULL,
+ value varchar
+ )")
+ :database con)
+
+ ;; (clsql::create-table [keyvalue]
+
+ ;; ;; This is most likely to work with any database system..
+ ;; '(
+ ;; ([clctn_id] integer :not-null)
+ ;; ([key] text :not-null)
+ ;; ([value] text)
+ ;; )
+ ;; :database con)
;; :constraints '("PRIMARY KEY (clctn_id key)"
;; "UNIQUE (clctn_id,key)")
@@ -338,6 +398,7 @@
(recover-fatal nil)
(thread t))
(declare (ignore recover recover-fatal thread))
+ (insure-thread-table-lock)
(the sql-store-controller
(let* ((dbtype (car (second (controller-spec sc))))
(path (cadr (second (controller-spec sc))))
@@ -346,7 +407,8 @@
(con (clsql:connect (cdr (second (controller-spec sc)))
:database-type dbtype
:if-exists :old)))
- (setf (slot-value sc 'db) con)
+ (setf (slot-value sc 'dbcons) (make-hash-table :test 'equal))
+;; (setf (slot-value sc 'db) con)
;; Now we should make sure that the KEYVALUE table exists, and, if
;; it does not, we need to create it..
(unless (keyvalue-table-exists con)
@@ -365,19 +427,45 @@
)
)
+(defmethod connection-ok-p ((sc sql-store-controller))
+ (connection-ok-p-con (controller-db sc)))
+
+(defun connection-ok-p-con (con)
+ (let ((str (format nil "~A" con)))
+ (search "OPEN" str)
+ ))
+
+(defmethod connection-really-ok-p ((sc sql-store-controller))
+ ;; I don't really have a good way of doing this, but
+ ;; one thing that is sure is that the the print form should
+ ;; have OPEN and not CLOSED in it.
+ )
+
+(defmethod controller-status ((sc sql-store-controller))
+;; This is a crummy way to deal with status; we really want
+;; to return something we can compute against.
+ (clsql:status)
+ )
+
+
(defmethod reconnect-controller ((sc sql-store-controller))
- (setf (controller-db sc)
- (clsql:reconnect :database (controller-db sc)))
+ (clsql:reconnect :database (controller-db sc) :force nil)
+;; (setf (controller-db sc)
+;; (clsql:reconnect :database (controller-db sc)))
)
+
(defmethod close-controller ((sc sql-store-controller))
- (when (slot-value sc 'db)
- ;; close the connection
- ;; (actually clsql has pooling and other complications, I am not sure
- ;; that this is complete.)
- (clsql:disconnect :database (controller-db sc))
- (setf (slot-value sc 'class-root) nil)
+ (maphash #'(lambda (k v)
+ (ignore-errors
+ (if (connection-ok-p-con v)
+ (clsql:disconnect :database v)
+ )
+ )
+ )
+ (controller-db-table sc)
+ )
(setf (slot-value sc 'root) nil)
- ))
+ )
;; Because this is part of the public
;; interface that I'm tied to, it has to accept a store-controller...
@@ -401,7 +489,6 @@
(defun sql-add-to-clcn (clcn key value sc
&key (insert-only nil))
- (declare (ignore sc))
(assert (integerp clcn))
(let ((con (controller-db sc))
(vbs
@@ -456,17 +543,17 @@
(let* ((con (controller-db sc))
(kbs
(serialize-to-base64-string key sc))
- (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by value offset ~A limit 1 "
+ (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by pk offset ~A limit 1 "
clcn
kbs
n))
(tuples
-;; (clsql::query offsetquery :database con)
- (clsql::select [value]
- :from [keyvalue]
- :where [and [= [clctn_id] clcn] [= [key] kbs]]
- :database con
- )
+ (clsql::query offsetquery :database con)
+;; (clsql::select [value]
+;; :from [keyvalue]
+;; :where [and [= [clctn_id] clcn] [= [key] kbs]]
+;; :database con
+;; )
)
)
;; Get the lowest value by sorting and taking the first value;
@@ -478,20 +565,21 @@
;; that efficiently without changing the database structure;
;; but that's OK, I could add a column to support that
;; relatively easily later on.
-;; (if (and (> (length tuples) 1))
-;; (format t "l = ~A~%" (length tuples))
-;; )
- (if (< n (length tuples))
-;; (values (deserialize-from-base64-string (car (nth n tuples)) sc)
-;; t)
- (values (nth n (sort
- (mapcar
- #'(lambda (x)
- (deserialize-from-base64-string (car x) sc))
- tuples)
- #'my-generic-less-than))
+ (if tuples
+ (values (deserialize-from-base64-string (caar tuples) sc)
t)
- (values nil nil))))
+ (values nil nil))
+
+;; (if (< n (length tuples))
+;; (values (nth n (sort
+;; (mapcar
+;; #'(lambda (x)
+;; (deserialize-from-base64-string (car x) sc))
+;; tuples)
+;; #'my-generic-less-than))
+;; t)
+;; (values nil nil))
+))
(defun sql-get-from-clcn-cnt (clcn key sc)
(assert (integerp clcn))
@@ -509,7 +597,7 @@
(assert (integerp clcn))
(let* ((con (controller-db sc))
(tuples
- (clsql::select [key] [value]
+ (clsql::select [pk] [key] [value]
:from [keyvalue]
:where [and [= [clctn_id] clcn]]
:database con
@@ -559,7 +647,6 @@
(defun sql-remove-from-clcn (clcn key sc)
- (declare (ignore sc))
(assert (integerp clcn))
(let ((con (controller-db sc))
(kbs (serialize-to-base64-string key sc))
More information about the Elephant-cvs
mailing list