[elephant-cvs] CVS elephant/src/db-bdb
ieslick
ieslick at common-lisp.net
Sun Feb 19 04:53:00 UTC 2006
Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory common-lisp:/tmp/cvs-serv7130/src/db-bdb
Added Files:
bdb-collections.lisp bdb-controller.lisp bdb-enable.lisp
bdb-transactions.lisp libsleepycat.c libutil.c package.lisp
sleepycat-old.lisp sleepycat.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; collections.lisp -- view Berkeley DBs as Lisp collections
;;;
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at common-lisp.net>
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package "SLEEPYCAT")
(defclass bdb-btree (btree) ()
(:documentation "A BerkleyDB implementation of a BTree"))
;; It would be nice if this were a macro or a function
;; that would allow all of its arguments to be passed through;
;; otherwise an initialization slot is inaccessible.
;; I'll worry about that later.
;; Do these things need to take &rest arguments?
(defmethod build-btree ((sc bdb-store-controller))
(make-instance 'bdb-btree :sc sc))
(defmethod get-value (key (bt bdb-btree))
(declare (optimize (speed 3) (space 0) (safety 0)))
(let ((sc (get-con bt)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered (controller-btrees sc)
key-buf value-buf)))
(if buf (values (deserialize buf :sc sc) T)
(values nil nil))))))
(defmethod existsp (key (bt bdb-btree))
(declare (optimize (speed 3) (safety 0) (space 0)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
(controller-btrees (get-con bt))
key-buf value-buf)))
(if buf t
nil))))
(defmethod (setf get-value) (value key (bt bdb-btree))
(declare (optimize (speed 3) (safety 0) (space 0)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(serialize value value-buf)
(db-put-buffered (controller-btrees (get-con bt))
key-buf value-buf
:auto-commit *auto-commit*)
value))
(defmethod remove-kv (key (bt bdb-btree))
(declare (optimize (speed 3) (space 0) (safety 0)))
(with-buffer-streams (key-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(db-delete-buffered (controller-btrees (get-con bt))
key-buf :auto-commit *auto-commit*)))
;; Secondary indices
(defclass bdb-indexed-btree (indexed-btree bdb-btree)
(
(indices :accessor indices :initform (make-hash-table))
(indices-cache :accessor indices-cache :initform (make-hash-table)
:transient t)
)
(:metaclass persistent-metaclass)
(:documentation "A BDB-based BTree supports secondary indices."))
(defmethod shared-initialize :after ((instance bdb-indexed-btree) slot-names
&rest rest)
(declare (ignore slot-names rest))
(setf (indices-cache instance) (indices instance)))
(defmethod build-indexed-btree ((sc bdb-store-controller))
(let ((bt (make-instance 'bdb-indexed-btree :sc sc)))
;; (setf (:dbcn-spc-pst bt) (controller-path sc))
;; I must be confused with multipler inheritance, because the above
;;; initforms in bdb-indexed-btree should be working, but aren't.
;; (setf (indices bt) (make-hash-table))
;; (setf (indices-cache bt) (make-hash-table))
bt))
(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form)
(let ((bt (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)))
;; (setf (:dbcn-spc-pst bt) (controller-path sc))
;; I must be confused with multipler inheritance, because the above
;;; initforms in bdb-indexed-btree should be working, but aren't.
bt))
(defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate)
(let ((sc (get-con bt)))
;; Setting the value of *store-controller* is unfortunately
;; absolutely required at present, I think because the copying
;; of objects is calling "make-instance" without an argument.
;; I am sure I can find a way to make this cleaner, somehow.
(if (and (not (null index-name))
(symbolp index-name) (or (symbolp key-form) (listp key-form)))
;; Can it be that this fails?
(let (
(ht (indices bt))
(index (build-btree-index sc :primary bt
:key-form key-form)))
(setf (gethash index-name (indices-cache bt)) index)
(setf (gethash index-name ht) index)
(setf (indices bt) ht)
(when populate
(let ((key-fn (key-fn index)))
(with-buffer-streams (primary-buf secondary-buf)
(with-transaction (:store-controller sc)
(map-btree
#'(lambda (k v)
(multiple-value-bind (index? secondary-key)
(funcall key-fn index k v)
(when index?
(buffer-write-int (oid bt) primary-buf)
(serialize k primary-buf)
(buffer-write-int (oid index) secondary-buf)
(serialize secondary-key secondary-buf)
;; should silently do nothing if
;; the key/value already exists
(db-put-buffered
(controller-indices sc)
secondary-buf primary-buf)
(reset-buffer-stream primary-buf)
(reset-buffer-stream secondary-buf))))
bt)))))
index)
(error "Invalid index initargs!")))
)
(defmethod map-indices (fn (bt bdb-indexed-btree))
(maphash fn (indices-cache bt)))
(defmethod get-index ((bt bdb-indexed-btree) index-name)
(gethash index-name (indices-cache bt)))
(defmethod remove-index ((bt bdb-indexed-btree) index-name)
(remhash index-name (indices-cache bt))
(let ((indices (indices bt)))
(remhash index-name indices)
(setf (indices bt) indices)))
(defmethod (setf get-value) (value key (bt bdb-indexed-btree))
"Set a key / value pair, and update secondary indices."
(let ((sc (get-con bt)))
(let ((indices (indices-cache bt)))
(with-buffer-streams (key-buf value-buf secondary-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(serialize value value-buf)
(with-transaction (:store-controller sc)
(db-put-buffered (controller-btrees sc)
key-buf value-buf)
(loop for index being the hash-value of indices
do
(multiple-value-bind (index? secondary-key)
(funcall (key-fn index) index key value)
(when index?
;; Manually write value into secondary index
(buffer-write-int (oid index) secondary-buf)
(serialize secondary-key secondary-buf)
;; should silently do nothing if the key/value already
;; exists
(db-put-buffered (controller-indices sc)
secondary-buf key-buf)
(reset-buffer-stream secondary-buf))))
value))))
)
(defmethod remove-kv (key (bt bdb-indexed-btree))
"Remove a key / value pair, and update secondary indices."
(declare (optimize (speed 3)))
(let ((sc (get-con bt)))
(with-buffer-streams (key-buf secondary-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(with-transaction (:store-controller sc)
(let ((value (get-value key bt)))
(when value
(let ((indices (indices-cache bt)))
(loop
for index being the hash-value of indices
do
(multiple-value-bind (index? secondary-key)
(funcall (key-fn index) index key value)
(when index?
(buffer-write-int (oid index) secondary-buf)
(serialize secondary-key secondary-buf)
;; need to remove kv pairs with a cursor! --
;; this is a C performance hack
(db-delete-kv-buffered
(controller-indices (get-con bt))
secondary-buf key-buf)
(reset-buffer-stream secondary-buf))))
(db-delete-buffered (controller-btrees (get-con bt))
key-buf))))))))
;; This also needs to build the correct kind of index, and
;; be the correct kind of btree...
(defclass bdb-btree-index (btree-index bdb-btree)
()
(:metaclass persistent-metaclass)
(:documentation "A BDB-based BTree supports secondary indices."))
;; I now think this code should be split out into a separate
;; class...
(defmethod get-value (key (bt bdb-btree-index))
"Get the value in the primary DB from a secondary key."
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
(controller-indices-assoc (get-con bt))
key-buf value-buf)))
(if buf (values (deserialize buf :sc (get-con bt)) T)
(values nil nil)))))
(defmethod get-primary-key (key (bt btree-index))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
(controller-indices (get-con bt))
key-buf value-buf)))
(if buf
(let ((oid (buffer-read-fixnum buf)))
(values (deserialize buf :sc (get-con bt)) oid))
(values nil nil)))))
;; Cursor operations
;; Node that I have not created a bdb-cursor, but have
;; created a sql-currsor. This is almost certainly wrong
;; and furthermore will badly screw things up when we get to
;; secondary cursors.
(defclass bdb-cursor (cursor)
((handle :accessor cursor-handle :initarg :handle))
(:documentation "A cursor for traversing (primary) BDB-BTrees."))
(defmethod make-cursor ((bt bdb-btree))
"Make a cursor from a btree."
(declare (optimize (speed 3)))
(make-instance 'bdb-cursor
:btree bt
:handle (db-cursor (controller-btrees (get-con bt)))
:oid (oid bt)))
(defmethod cursor-close ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(db-cursor-close (cursor-handle cursor))
(setf (cursor-initialized-p cursor) nil))
(defmethod cursor-duplicate ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(make-instance (type-of cursor)
:initialized-p (cursor-initialized-p cursor)
:oid (cursor-oid cursor)
:handle (db-cursor-duplicate
(cursor-handle cursor)
:position (cursor-initialized-p cursor))))
(defmethod cursor-current ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf
:current t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))))
(defmethod cursor-first ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
(multiple-value-bind (key val)
(db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set-range t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil)))))
;;A bit of a hack.....
(defmethod cursor-last ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (+ (cursor-oid cursor) 1) key-buf)
(if (db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set-range t)
(progn (reset-buffer-stream key-buf)
(reset-buffer-stream value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :prev t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor) key-buf
value-buf :last t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))))
(defmethod cursor-next ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :next t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(values t (deserialize key :sc (get-con (cursor-btree cursor)))
(deserialize val :sc (get-con (cursor-btree cursor))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-first cursor)))
(defmethod cursor-prev ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :prev t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(values t (deserialize key :sc (get-con (cursor-btree cursor)))
(deserialize val :sc (get-con (cursor-btree cursor))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-last cursor)))
(defmethod cursor-set ((cursor bdb-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
(serialize key key-buf)
(multiple-value-bind (k val)
(db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
(values t key (deserialize val :sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil)))))
(defmethod cursor-set-range ((cursor bdb-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
(serialize key key-buf)
(multiple-value-bind (k val)
(db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set-range t)
(if (and k (= (buffer-read-int k) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
(values t (deserialize k :sc (get-con (cursor-btree cursor)))
(deserialize val :sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil)))))
(defmethod cursor-get-both ((cursor bdb-cursor) key value)
(declare (optimize (speed 3)))
[360 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 1.1
[557 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-enable.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-enable.lisp 2006/02/19 04:53:00 1.1
[646 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 1.1
[741 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.c 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.c 2006/02/19 04:53:00 1.1
[1734 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/libutil.c 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libutil.c 2006/02/19 04:53:00 1.1
[1845 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/02/19 04:53:00 1.1
[1888 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat-old.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat-old.lisp 2006/02/19 04:53:00 1.1
[2953 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 04:53:00 1.1
[4821 lines skipped]
More information about the Elephant-cvs
mailing list