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))