[elephant-cvs] CVS elephant/src/db-bdb

19 Feb 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@common-lisp.net
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; ablumberg@common-lisp.net blee@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]

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

[elephant-cvs] CVS elephant/src/db-bdb