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]