Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory common-lisp:/tmp/cvs-serv14267/src/db-clsql
Modified Files:
sql-collections.lisp sql-controller.lisp
Log Message:
Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 16:22:40 1.2
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 20:06:03 1.3
@@ -19,11 +19,6 @@
(in-package "ELEPHANT-CLSQL")
-(defclass sql-btree-index (btree-index sql-btree)
- ()
- (:metaclass persistent-metaclass)
- (:documentation "A SQL-based BTree supports secondary indices."))
-
(defmethod get-value (key (bt sql-btree-index))
"Get the value in the primary DB from a secondary key."
(declare (optimize (speed 3)))
@@ -234,6 +229,7 @@
(progn
(multiple-value-bind (h k v)
(cursor-next cursor)
+ (declare (ignore h v))
(when (my-generic-less-than key k)
(setf vs t))
)
@@ -285,7 +281,8 @@
"Put by cursor. Not particularly useful since primaries
don't support duplicates. Currently doesn't properly move
the cursor."
- (declare (optimize (speed 3)))
+ (declare (optimize (speed 3))
+ (ignore key value key-specified-p))
(error "Puts on sql-cursors are not yet implemented, because I can't get them to work on BDB cursors!"))
;; Secondary Cursors
@@ -451,7 +448,7 @@
(remove-kv p (primary (cursor-btree cursor)))
(let ((ck (:sql-crsr-ck cursor))
(dp (:dp-nmbr cursor)))
-
+ (declare (ignorable dp))
(cursor-next cursor)
;; Now that we point to the old slot, remove the old slot from the array...
(setf (:sql-crsr-ks cursor)
@@ -466,20 +463,20 @@
(defmethod cursor-get-both ((cursor sql-secondary-cursor) key value)
"cursor-get-both not implemented for secondary indices.
Use cursor-pget-both."
- (declare (ignore cursor key value))
+ (declare (ignore key value))
(error "cursor-get-both not implemented on secondary
indices. Use cursor-pget-both."))
(defmethod cursor-get-both-range ((cursor sql-secondary-cursor) key value)
"cursor-get-both-range not implemented for secondary indices.
Use cursor-pget-both-range."
- (declare (ignore cursor key value))
+ (declare (ignore key value))
(error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range."))
(defmethod cursor-put ((cursor sql-secondary-cursor) value &rest rest)
"Puts are forbidden on secondary indices. Try adding to
the primary."
- (declare (ignore rest value cursor))
+ (declare (ignore rest value))
(error "Puts are forbidden on secondary indices. Try adding to the primary."))
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 16:22:40 1.3
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 20:06:03 1.4
@@ -26,91 +26,75 @@
;;; other clsql packages would have to be added for
;;; non-postgresql databases, see the CL-SQL documentation
-(eval-when (:compile-toplevel :load-toplevel)
- ;; NOTE: Integrate into load process
- ;; Probably must be customized ... see documentation on installin postgres.
- (defvar *clsql-foreign-lib-path* "/usr/lib")
- (clsql:push-library-path *clsql-foreign-lib-path*)
- (clsql:push-library-path *elephant-lib-path*))
+;; (eval-when (:compile-toplevel :load-toplevel)
+;; ;; NOTE: Integrate into load process
+;; ;; Probably must be customized ... see documentation on installin postgres.
+;; (defvar *clsql-foreign-lib-path* "/usr/lib")
+;; (clsql:push-library-path *clsql-foreign-lib-path*)
+;; (clsql:push-library-path *elephant-lib-path*))
+
+
+;;
+;; The main SQL Controller Class
+;;
+
(defclass sql-store-controller (store-controller)
- ((dbonnection-spec :type list :accessor :dbcn-spc :initarg :dbconnection-spec
- ;; for postgres, this is host, db, user, password
- ;; If you can't get the lisp system to connect with
- ;; this default information, make sure you can connect
- ;; to the database called "test" under the user postgress
- ;; with the psql console first. Then study the authorization
- ;; and configuration files.
- :initform '("localhost.localdomain" "test" "postgres" ""))
- (db :accessor controller-db :initarg :db :initform nil))
+ ((db :accessor controller-db :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."))
-(defmethod build-btree ((sc sql-store-controller))
- (make-sql-btree sc))
+(eval-when (:compile-toplevel :load-toplevel)
+ (register-backend-con-init :clsql 'sql-test-and-construct))
+
+(defun sql-test-and-construct (spec)
+ "Entry function for making SQL backend controllers"
+ (if (sql-store-spec-p spec)
+ (make-instance 'sql-store-controller
+ :spec (if spec spec
+ '("localhost.localdomain" "test" "postgres" "")))
+ (error (format nil "uninterpretable path/spec specifier: ~A" spec))))
(defun sql-store-spec-p (spec)
(and (listp spec)
(eq (first spec) :clsql)))
-(defun sql-test-and-construct (spec)
- (if (sql-store-spec-p spec)
- (open-store-sql spec)
- nil))
-
-(eval-when (:load-toplevel)
- (register-backend-con-init :clsql 'sql-test-and-construct))
+;;
+;; Controller Indices
+;;
-(defmacro with-open-store-sql ((spec) &body body)
- "Executes the body with an open controller,
-unconditionally closing the controller on exit."
- `(let ((*store-controller*
- (make-instance 'sql-store-controller :dbconnection-spec ,spec)))
- (declare (special *store-controller*))
- (open-controller *store-controller*)
- (unwind-protect
- (progn ,@body)
- (close-controller *store-controller*))))
-
-(defun open-store-sql (spec &key (recover nil)
- (recover-fatal nil) (thread t))
- "Conveniently open a store controller."
- (setq *store-controller*
- (if (sql-store-spec-p spec)
- (make-instance 'sql-store-controller :dbconnection-spec spec)
- (error (format nil "uninterpretable path/spec specifier: ~A" spec)))
- )
- (open-controller *store-controller* :recover recover
- :recover-fatal recover-fatal :thread thread)
- )
;; When you build one of these, you have to put in the connection spec.
-(defclass sql-btree (btree)
- (
- )
+(defclass sql-btree (btree) ()
(:documentation "A SQL implementation of a BTree"))
+(defmethod build-btree ((sc sql-store-controller))
+ (make-instance 'sql-btree :sc sc)
+ )
+
(defmethod get-value (key (bt sql-btree))
(let* ((sc (get-con bt))
(con (controller-db sc)))
- (sql-get-from-clcn (oid bt) key sc con)))
-
+ (sql-get-from-clcn (oid bt) key sc con)
+ )
+ )
-(defmethod existsp (key (bt sql-btree))
+(defmethod (setf get-value) (value key (bt sql-btree))
(let* ((sc (get-con bt))
(con (controller-db sc)))
- (sql-from-clcn-existsp (oid bt) key con)
+ (sql-add-to-clcn (oid bt) key value sc con)
)
)
-(defmethod (setf get-value) (value key (bt sql-btree))
+(defmethod existsp (key (bt sql-btree))
(let* ((sc (get-con bt))
(con (controller-db sc)))
- (sql-add-to-clcn (oid bt) key value sc con)
+ (sql-from-clcn-existsp (oid bt) key con)
)
)
+
(defmethod remove-kv (key (bt sql-btree))
(let* ((sc (get-con bt))
(con (controller-db sc)))
@@ -125,40 +109,47 @@
;; directly into the class above. I am not sure how best to
;; handle this problem.
(defclass sql-indexed-btree (indexed-btree sql-btree )
- (
- (indices :accessor indices :initform (make-hash-table)
- )
+ ((indices :accessor indices :initform (make-hash-table))
(indices-cache :accessor indices-cache :initform (make-hash-table)
- :transient t)
- )
+ :transient t))
(:metaclass persistent-metaclass)
(:documentation "A SQL-based BTree that supports secondary indices."))
+(defmethod shared-initialize :after ((instance sql-indexed-btree) slot-names
+ &rest rest)
+ (declare (ignore slot-names rest))
+ (setf (indices-cache instance) (indices instance)))
+
(defmethod build-indexed-btree ((sc sql-store-controller))
- (let ((bt (make-instance 'sql-indexed-btree :sc sc)))
- (setf (:dbcn-spc-pst bt) (:dbcn-spc sc))
- bt
- ))
+ (make-instance 'sql-indexed-btree :sc sc))
(defmethod build-btree-index ((sc sql-store-controller) &key primary key-form)
- (let ((bt (make-instance 'sql-btree-index :primary primary :key-form key-form :sc sc)))
- (setf (:dbcn-spc-pst bt) (:dbcn-spc sc))
- bt
- ))
+ (make-instance 'sql-btree-index :primary primary :key-form key-form :sc sc))
-;; I need some way to get to the store-controller here...
-;; I could be the store controller in the hash table, that's probably
-;; the simplest thing to do..
+;; ISE NOTE: Much of the index management functionality is common between
+;; bdb and sql - we could lift this along with indices and indices-cache
+;; up to the main elephant code base and introduce a new update-index
+;; generic function to handle the backend specific method for updating
+(defmethod map-indices (fn (bt sql-indexed-btree))
+ (maphash fn (indices-cache bt)))
+
+(defmethod get-index ((bt sql-indexed-btree) index-name)
+ (gethash index-name (indices-cache bt)))
+
+(defmethod remove-index ((bt sql-indexed-btree) index-name)
+ (remhash index-name (indices-cache bt))
+ (let ((indices (indices bt)))
+ (remhash index-name indices)
+ (setf (indices bt) indices)))
+
(defmethod add-index ((bt sql-indexed-btree) &key index-name key-form populate)
(let* ((sc (get-con bt))
- (con (controller-db sc)))
+ (con (controller-db sc)))
(if (and (not (null index-name))
(symbolp index-name) (or (symbolp key-form) (listp key-form)))
(let ((indices (indices bt))
- (index (make-instance 'sql-btree-index :primary bt
- :key-form key-form
- :sc sc)))
+ (index (build-btree-index sc :primary bt :key-form key-form)))
(setf (gethash index-name (indices-cache bt)) index)
(setf (gethash index-name indices) index)
(setf (indices bt) indices)
@@ -190,6 +181,7 @@
(with-transaction (:store-controller sc)
(maphash
#'(lambda (k index)
+ (declare (ignore k))
(multiple-value-bind (index? secondary-key)
(funcall (key-fn index) index key value)
(when index?
@@ -216,6 +208,7 @@
(let ((indices (indices-cache bt)))
(maphash
#'(lambda (k index)
+ (declare (ignore k))
(multiple-value-bind (index? secondary-key)
(funcall (key-fn index) index key value)
(when index?
@@ -237,7 +230,6 @@
value))))
-
(defclass sql-btree-index (btree-index sql-btree)
()
(:metaclass persistent-metaclass)
@@ -290,8 +282,9 @@
;; apparently in postgres this is failing pretty awfully because
;; sequence-exists-p return nil and then we get an error that the sequence exists!
;; (unless (sequence-exists-p [persistent_seq])
- (clsql::create-sequence [persistent_seq]
- :database con)
+ (clsql::create-sequence [persistent_seq] :database con)
+ ;; Leave room for root and class-root
+ (clsql::set-sequence-position [persistent_seq] 2 :database con)
;;)
;; (unless (index-exists-p [idx_clctn_id])
(clsql::create-index [idx_clctn_id] :on [keyvalue]
@@ -311,16 +304,16 @@
;;)
)
-
(defmethod open-controller ((sc sql-store-controller)
;; At present these three have no meaning
&key
(recover nil)
(recover-fatal nil)
(thread t))
+ (declare (ignore recover recover-fatal thread))
(the sql-store-controller
- (let* ((dbtype (car (second (:dbcn-spc sc))))
- (con (clsql:connect (cdr (second (:dbcn-spc sc)))
+ (let* ((dbtype (car (second (controller-spec sc))))
+ (con (clsql:connect (cdr (second (controller-spec sc)))
;; WARNING: This line of code forces us to use postgresql.
;; If this were parametrized upwards we could concievably try
;; other backends.
@@ -328,7 +321,6 @@
;; DNK :postgresql
;; :database-type :postgresql
:if-exists :old)))
- (setf (gethash (:dbcn-spc sc) *dbconnection-spec*) sc)
(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..
@@ -336,32 +328,22 @@
;; can put it in a function....
(unless (keyvalue-table-exists con)
(create-keyvalue-table con))
- (setf (slot-value sc 'root) (build-btree sc))
- (setf (slot-value sc 'class-root) (build-indexed-btree sc))
- ;; Actaully, it would seem here that we must further set the oid
- ;; of the root tree to 0 to ensure that we read the correct thing
- ;; when we next opent he controller...
- (setf (oid (slot-value sc 'root)) 0)
+ ;; These should get oid 0 and 1 respectively
+ (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0))
+ (setf (slot-value sc 'class-root) (make-instance 'sql-indexed-btree :sc sc :from-oid 1))
sc)
)
)
-(defun make-sql-btree (sc)
- (let ((bt (make-instance 'sql-btree :sc sc)))
- (setf (:dbcn-spc-pst bt) (:dbcn-spc sc))
- bt)
- )
-
(defmethod close-controller ((sc sql-store-controller))
(when (slot-value sc 'db)
- ;; close the conneciton
+ ;; 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 'root) nil)
))
-
;; Because this is part of the public
;; interface that I'm tied to, it has to accept a store-controller...
(defmethod next-oid ((sc sql-store-controller ))
@@ -370,7 +352,6 @@
:database con))
)
-
;; if add-to-root is a method, then we can make it class dependent...
;; otherwise we have to change the original code. There is
;; almost no way to implement this without either changing the existing
@@ -379,15 +360,14 @@
;; a proper method myself, but I will give it a name so it doesn't
;; conflict with 'add-to-root. 'add-to-root can remain a convenience symbol,
;; that will end up calling this routine!
-(defmethod sql-add-to-root (key value (pgsc sql-store-controller ) con)
+(defun sql-add-to-root (key value pgsc con)
(sql-add-to-clcn 0 key value pgsc con)
)
-;;(defmethod sql-add-to-root (key value dbcon)
-;; (sql-add-to-clcn 0 key value sc dbcon)
-;; )
-(defmethod sql-add-to-clcn ((clcn integer) key value sc con
+(defun sql-add-to-clcn (clcn key value sc con
&key (insert-only nil))
+ (declare (ignore sc))
+ (assert (integerp clcn))
(let (
(vbs
(serialize-to-base64-string value))
@@ -411,9 +391,9 @@
)
-
-(defmethod sql-get-from-root (key sc con)
- (sql-get-from-clcn 0 key sc con))
+(defun sql-get-from-root (key sc con)
+ (sql-get-from-clcn 0 key sc con)
+ )
;; This is a major difference betwen SQL and BDB:
;; BDB plans to give you one value and let you iterate, but
@@ -431,10 +411,13 @@
;; To do that I have to read in all of the values and deserialized them
;; This could be a good reason to keep the oids out, and separte, in
;; a separate column.
-(defmethod sql-get-from-clcn ((clcn integer) key sc con)
+(defun sql-get-from-clcn (clcn key sc con)
+ (assert (integerp clcn))
(sql-get-from-clcn-nth clcn key sc con 0)
)
-(defmethod sql-get-from-clcn-nth ((clcn integer) key sc con (n integer))
+
+(defun sql-get-from-clcn-nth (clcn key sc con n)
+ (assert (and (integerp clcn) (integerp n)))
(let* (
(kbs
(serialize-to-base64-string key))
@@ -463,7 +446,8 @@
t)
(values nil nil))))
-(defmethod sql-get-from-clcn-cnt ((clcn integer) key con)
+(defun sql-get-from-clcn-cnt (clcn key con)
+ (assert (integerp clcn))
(let* (
(kbs (serialize-to-base64-string key))
(tuples
@@ -474,7 +458,8 @@
)))
(caar tuples)))
-(defmethod sql-dump-clcn ((clcn integer) sc con)
+(defun sql-dump-clcn (clcn sc con)
+ (assert (integerp clcn))
(let* (
(tuples
(clsql::select [key] [value]
@@ -485,11 +470,12 @@
(mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string q :sc sc)) x))
tuples)))
-(defmethod sql-from-root-existsp (key con)
+(defun sql-from-root-existsp (key con)
(sql-from-clcn-existsp 0 key con)
)
-(defmethod sql-from-clcn-existsp ((clcn integer) key con)
+(defun sql-from-clcn-existsp (clcn key con)
+ (assert (integerp clcn))
(let* (
(kbs (with-buffer-streams (out-buf)
(serialize-to-base64-string key))
@@ -505,11 +491,14 @@
nil)
))
-(defmethod sql-remove-from-root (key sc con)
+(defun sql-remove-from-root (key sc con)
[53 lines skipped]
