[elephant-cvs] CVS update: elephant/src/RUNTEST.lisp elephant/src/bdb-enable.lisp elephant/src/libmemutil.c elephant/src/libutil.c elephant/src/sql-collections.lisp elephant/src/sql-controller.lisp elephant/src/sql-tutorial.lisp elephant/src/classes.lisp elephant/src/collections.lisp elephant/src/controller.lisp elephant/src/elephant.lisp elephant/src/libsleepycat.c elephant/src/metaclasses.lisp elephant/src/serializer.lisp elephant/src/sleepycat.lisp elephant/src/utils.lisp
Robert L. Read
rread at common-lisp.net
Wed Nov 23 17:52:00 UTC 2005
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv30677/src
Modified Files:
classes.lisp collections.lisp controller.lisp elephant.lisp
libsleepycat.c metaclasses.lisp serializer.lisp sleepycat.lisp
utils.lisp
Added Files:
RUNTEST.lisp bdb-enable.lisp libmemutil.c libutil.c
sql-collections.lisp sql-controller.lisp sql-tutorial.lisp
Log Message:
This is the big merger from the SQL-BACK-END branch.
Date: Wed Nov 23 18:51:41 2005
Author: rread
Index: elephant/src/RUNTEST.lisp
diff -u /dev/null elephant/src/RUNTEST.lisp:1.2
--- /dev/null Wed Nov 23 18:51:41 2005
+++ elephant/src/RUNTEST.lisp Wed Nov 23 18:51:37 2005
@@ -0,0 +1,44 @@
+(asdf:operate 'asdf:load-op :elephant)
+(asdf:operate 'asdf:load-op :ele-clsql)
+(asdf:oos 'asdf:load-op :clsql-postgresql-socket)
+(asdf:operate 'asdf:load-op :ele-bdb)
+(asdf:operate 'asdf:load-op :elephant-tests)
+
+(asdf:operate 'asdf:load-op :ele-sqlite3)
+
+
+(in-package "ELEPHANT-TESTS")
+(do-all-tests)
+(do-all-tests-spec *testpg-path*)
+(do-migrate-test-spec *testpg-path*)
+(do-all-tests-spec *testdb-path*)
+(do-all-tests-spec *testsqlite3-path*)
+
+;; The primary and secondary test-paths are
+;; use for the migration tests.
+(setq *test-path-primary* *testpg-path*)
+(setq *test-path-primary* *testsqlite3-path*)
+(setq *test-path-secondary* *testdb-path*)
+(do-all-tests-spec *test-path-primary*)
+
+
+(use-package :sb-profile)
+
+(profile "CLSQL")
+(profile "POSTGRESQL-SOCKET")
+(profile "ELEPHANT")
+
+(use-package "SB-PROFILE")
+
+(open-store *testpg-path*)
+(open-store *testdb-path*)
+(add-to-root "x1" "y1")
+(get-from-root "x1")
+
+
+(add-to-root "x2" '(a 4 "spud"))
+(get-from-root "x2")
+
+
+
+
Index: elephant/src/bdb-enable.lisp
diff -u /dev/null elephant/src/bdb-enable.lisp:1.2
--- /dev/null Wed Nov 23 18:51:42 2005
+++ elephant/src/bdb-enable.lisp Wed Nov 23 18:51:37 2005
@@ -0,0 +1,107 @@
+(in-package "SLEEPYCAT")
+
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; controller.lisp -- Lisp interface to a Berkeley DB store
+;;;
+;;; 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>
+;;;
+;;; This program is released under the following license
+;;; ("GPL"). For differenct licensing terms, contact the
+;;; copyright holders.
+;;;
+;;; This program is free software; you can redistribute it
+;;; and/or modify it under the terms of the GNU General
+;;; Public License as published by the Free Software
+;;; Foundation; either version 2 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the
+;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
+;;; PARTICULAR PURPOSE. See the GNU General Public License
+;;; for more details.
+;;;
+;;; The GNU General Public License can be found in the file
+;;; LICENSE which should have been distributed with this
+;;; code. It can also be found at
+;;;
+;;; http://www.opensource.org/licenses/gpl-license.php
+;;;
+;;; You should have received a copy of the GNU General
+;;; Public License along with this program; if not, write
+;;; to the Free Software Foundation, Inc., 59 Temple Place,
+;;; Suite 330, Boston, MA 02111-1307 USA
+;;;
+
+
+#+cmu
+(eval-when (:compile-toplevel)
+ (proclaim '(optimize (ext:inhibit-warnings 3))))
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; UFFI
+ ;;(asdf:operate 'asdf:load-op :uffi)
+
+ ;; DSO loading - Edit these for your system!
+
+ ;; Under linux you may need to load some kind of pthread
+ ;; library. I can't figure out which is the right one.
+ ;; This one worked for me. There are known issues with
+ ;; Red Hat and Berkeley DB, search google.
+ #+linux
+ (unless
+ (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread")
+ (error "Couldn't load libpthread!"))
+
+ (unless
+ (uffi:load-foreign-library
+ (if (find-package 'asdf)
+ (merge-pathnames
+ #p"libmemutil.so"
+ (asdf:component-pathname (asdf:find-system 'elephant)))
+ "/usr/local/share/common-lisp/elephant-0.3/libmemutil.so")
+ :module "libmemutil")
+ (error "Couldn't load libmemutil.so!"))
+
+
+;; This code has now been moved to the small, asdf-loadable system
+;; called "bdb-enable". Do : (asdf:operate 'asdf:load-op :ele-bdb)
+;; to enable the use of BerkeleyDB as a back store.
+ (unless
+ (uffi:load-foreign-library
+ ;; Sleepycat: this works on linux
+ #+linux
+;; "/db/ben/lisp/db43/lib/libdb.so"
+ "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so"
+ ;; this works on FreeBSD
+ #+(and (or bsd freebsd) (not darwin))
+ "/usr/local/lib/db43/libdb.so"
+ #+darwin
+ ;; for Fink (OS X) -- but I will assume Linux more common...
+;; "/sw/lib/libdb-4.3.dylib"
+ ;; a possible manual install
+ "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib"
+ :module "sleepycat")
+ (error "Couldn't load libdb (Sleepycat)!"))
+
+ ;; Libsleepycat.so: edit this
+ (unless
+ (uffi:load-foreign-library
+ (if (find-package 'asdf)
+ (merge-pathnames
+ #p"libsleepycat.so"
+ (asdf:component-pathname (asdf:find-system 'elephant)))
+ "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.so")
+ :module "libsleepycat")
+ (error "Couldn't load libsleepycat!"))
+
+)
Index: elephant/src/libmemutil.c
diff -u /dev/null elephant/src/libmemutil.c:1.2
--- /dev/null Wed Nov 23 18:51:45 2005
+++ elephant/src/libmemutil.c Wed Nov 23 18:51:37 2005
@@ -0,0 +1,111 @@
+/*
+;;;
+;;; libsleepycat.c -- C wrappers for Sleepycat for FFI
+;;;
+;;; 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>
+;;;
+;;; This program is released under the following license
+;;; ("GPL"). For differenct licensing terms, contact the
+;;; copyright holders.
+;;;
+;;; This program is free software; you can redistribute it
+;;; and/or modify it under the terms of the GNU General
+;;; Public License as published by the Free Software
+;;; Foundation; either version 2 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the
+;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
+;;; PARTICULAR PURPOSE. See the GNU General Public License
+;;; for more details.
+;;;
+;;; The GNU General Public License can be found in the file
+;;; LICENSE which should have been distributed with this
+;;; code. It can also be found at
+;;;
+;;; http://www.opensource.org/licenses/gpl-license.php
+;;;
+;;; You should have received a copy of the GNU General
+;;; Public License along with this program; if not, write
+;;; to the Free Software Foundation, Inc., 59 Temple Place,
+;;; Suite 330, Boston, MA 02111-1307 USA
+;;;
+;;; Portions of this program (namely the C unicode string
+;;; sorter) are derived from IBM's ICU:
+;;;
+;;; http://oss.software.ibm.com/icu/
+;;;
+;;; Copyright (c) 1995-2003 International Business Machines
+;;; Corporation and others All rights reserved.
+;;;
+;;; ICU's copyright, license and warranty can be found at
+;;;
+;;; http://oss.software.ibm.com/cvs/icu/~checkout~/icu/license.html
+;;;
+;;; or in the file LICENSE.
+;;;
+*/
+
+#include <string.h>
+#include <wchar.h>
+
+/* Pointer arithmetic utility functions */
+/* should these be in network-byte order? probably not..... */
+int read_int(char *buf, int offset) {
+ int i;
+ memcpy(&i, buf+offset, sizeof(int));
+ return i;
+}
+
+unsigned int read_uint(char *buf, int offset) {
+ unsigned int ui;
+ memcpy(&ui, buf+offset, sizeof(unsigned int));
+ return ui;
+}
+
+float read_float(char *buf, int offset) {
+ float f;
+ memcpy(&f, buf+offset, sizeof(float));
+ return f;
+}
+
+double read_double(char *buf, int offset) {
+ double d;
+ memcpy(&d, buf+offset, sizeof(double));
+ return d;
+}
+
+void write_int(char *buf, int num, int offset) {
+ memcpy(buf+offset, &num, sizeof(int));
+}
+
+void write_uint(char *buf, unsigned int num, int offset) {
+ memcpy(buf+offset, &num, sizeof(unsigned int));
+}
+
+void write_float(char *buf, float num, int offset) {
+ memcpy(buf+offset, &num, sizeof(float));
+}
+
+void write_double(char *buf, double num, int offset) {
+ memcpy(buf+offset, &num, sizeof(double));
+}
+
+char *offset_charp(char *p, int offset) {
+ return p + offset;
+}
+
+void copy_buf(char *dest, int dest_offset, char *src, int src_offset,
+ int length) {
+ memcpy(dest + dest_offset, src + src_offset, length);
+}
+
Index: elephant/src/libutil.c
diff -u /dev/null elephant/src/libutil.c:1.2
--- /dev/null Wed Nov 23 18:51:45 2005
+++ elephant/src/libutil.c Wed Nov 23 18:51:37 2005
@@ -0,0 +1,111 @@
+/*
+;;;
+;;; libsleepycat.c -- C wrappers for Sleepycat for FFI
+;;;
+;;; 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>
+;;;
+;;; This program is released under the following license
+;;; ("GPL"). For differenct licensing terms, contact the
+;;; copyright holders.
+;;;
+;;; This program is free software; you can redistribute it
+;;; and/or modify it under the terms of the GNU General
+;;; Public License as published by the Free Software
+;;; Foundation; either version 2 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the
+;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
+;;; PARTICULAR PURPOSE. See the GNU General Public License
+;;; for more details.
+;;;
+;;; The GNU General Public License can be found in the file
+;;; LICENSE which should have been distributed with this
+;;; code. It can also be found at
+;;;
+;;; http://www.opensource.org/licenses/gpl-license.php
+;;;
+;;; You should have received a copy of the GNU General
+;;; Public License along with this program; if not, write
+;;; to the Free Software Foundation, Inc., 59 Temple Place,
+;;; Suite 330, Boston, MA 02111-1307 USA
+;;;
+;;; Portions of this program (namely the C unicode string
+;;; sorter) are derived from IBM's ICU:
+;;;
+;;; http://oss.software.ibm.com/icu/
+;;;
+;;; Copyright (c) 1995-2003 International Business Machines
+;;; Corporation and others All rights reserved.
+;;;
+;;; ICU's copyright, license and warranty can be found at
+;;;
+;;; http://oss.software.ibm.com/cvs/icu/~checkout~/icu/license.html
+;;;
+;;; or in the file LICENSE.
+;;;
+*/
+
+#include <string.h>
+#include <wchar.h>
+
+/* Pointer arithmetic utility functions */
+/* should these be in network-byte order? probably not..... */
+int read_int(char *buf, int offset) {
+ int i;
+ memcpy(&i, buf+offset, sizeof(int));
+ return i;
+}
+
+unsigned int read_uint(char *buf, int offset) {
+ unsigned int ui;
+ memcpy(&ui, buf+offset, sizeof(unsigned int));
+ return ui;
+}
+
+float read_float(char *buf, int offset) {
+ float f;
+ memcpy(&f, buf+offset, sizeof(float));
+ return f;
+}
+
+double read_double(char *buf, int offset) {
+ double d;
+ memcpy(&d, buf+offset, sizeof(double));
+ return d;
+}
+
+void write_int(char *buf, int num, int offset) {
+ memcpy(buf+offset, &num, sizeof(int));
+}
+
+void write_uint(char *buf, unsigned int num, int offset) {
+ memcpy(buf+offset, &num, sizeof(unsigned int));
+}
+
+void write_float(char *buf, float num, int offset) {
+ memcpy(buf+offset, &num, sizeof(float));
+}
+
+void write_double(char *buf, double num, int offset) {
+ memcpy(buf+offset, &num, sizeof(double));
+}
+
+char *offset_charp(char *p, int offset) {
+ return p + offset;
+}
+
+void copy_buf(char *dest, int dest_offset, char *src, int src_offset,
+ int length) {
+ memcpy(dest + dest_offset, src + src_offset, length);
+}
+
Index: elephant/src/sql-collections.lisp
diff -u /dev/null elephant/src/sql-collections.lisp:1.2
--- /dev/null Wed Nov 23 18:51:46 2005
+++ elephant/src/sql-collections.lisp Wed Nov 23 18:51:37 2005
@@ -0,0 +1,640 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; sql-controller.lisp -- Interface to a CLSQL based object store.
+;;;
+;;; Initial version 10/12/2005 by Robert L. Read
+;;; <read at robertlread.net>
+;;;
+;;; part of
+;;;
+;;; Elephant: an object-oriented database for Common Lisp
+;;;
+;;; Copyright (c) 2005 by Robert L. Read
+;;;
+;;; This program is released under the following license
+;;; ("GPL"). For differenct licensing terms, contact the
+;;; copyright holders.
+;;;
+;;; This program is free software; you can redistribute it
+;;; and/or modify it under the terms of the GNU General
+;;; Public License as published by the Free Software
+;;; Foundation; either version 2 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the
+;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
+;;; PARTICULAR PURPOSE. See the GNU General Public License
+;;; for more details.
+;;;
+;;; The GNU General Public License can be found in the file
+;;; LICENSE which should have been distributed with this
+;;; code. It can also be found at
+;;;
+;;; http://www.opensource.org/licenses/gpl-license.php
+;;;
+;;; You should have received a copy of the GNU General
+;;; Public License along with this program; if not, write
+;;; to the Free Software Foundation, Inc., 59 Temple Place,
+;;; Suite 330, Boston, MA 02111-1307 USA
+;;;
+
+(in-package "ELEPHANT")
+
+
+(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)))
+ ;; Below, the take the oid and add it to the key, then look
+ ;; thing up--- where?
+
+ ;; Somehow I suspect that what I am getting back here
+ ;; is actually the main key...
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc)))
+ (let ((pk (sql-get-from-clcn (oid bt) key sc con)))
+ (if pk
+ (sql-get-from-clcn (oid (primary bt)) pk sc con))
+ )))
+
+(defmethod get-primary-key (key (bt sql-btree-index))
+ (declare (optimize (speed 3)))
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc))
+ )
+ (sql-get-from-clcn (oid bt) key sc con)))
+
+
+;; My basic strategy is to keep track of a current key
+;; and to store all keys in memory so that we can sort them
+;; to implement the cursor semantics. Clearly, passing
+;; in a different ordering is a nice feature to have here.
+(defclass sql-cursor (cursor)
+ ((keys :accessor :sql-crsr-ks :initarg :sql-cursor-keys :initform '())
+ (curkey :accessor :sql-crsr-ck :initarg :sql-cursor-curkey :initform -1 :type integer))
+ (:documentation "A SQL cursor for traversing (primary) BTrees."))
+
+(defmethod make-cursor ((bt sql-btree))
+ "Make a cursor from a btree."
+ (declare (optimize (speed 3)))
+ (make-instance 'sql-cursor
+ :btree bt
+ :oid (oid bt)))
+
+
+
+(defmethod cursor-close ((cursor sql-cursor))
+ (setf (:sql-crsr-ck cursor) nil)
+ (setf (cursor-initialized-p cursor) nil))
+
+;; Maybe this will still work?
+;; I'm not sure what cursor-duplicate is meant to do, and if
+;; the other state needs to be copied or now. Probably soo...
+(defmethod cursor-duplicate ((cursor sql-cursor))
+ (declare (optimize (speed 3)))
+ (make-instance (type-of cursor)
+ :initialized-p (cursor-initialized-p cursor)
+ :oid (cursor-oid cursor)
+ ;; Do we need to so some kind of copy on this collection?
+ :keys (:sql-crsr-ks cursor)
+ :curkey (:sql-crsr-ck cursor)
+ :handle (db-cursor-duplicate
+ (cursor-handle cursor)
+ :position (cursor-initialized-p cursor))))
+
+(defmethod cursor-current ((cursor sql-cursor))
+ (declare (optimize (speed 3)))
+ (when (cursor-initialized-p cursor)
+ (has-key-value cursor)))
+
+;; Only for use within an operation...
+(defun my-generic-less-than (a b)
+ (cond
+ ((and (typep a 'persistent) (typep b 'persistent))
+ (< (oid a) (oid b))
+ )
+ ((and (numberp a ) (numberp b))
+ (< a b))
+ ((and (stringp a) (stringp b))
+ (string< a b))
+ (t
+ (string< (format nil "~A" a) (format nil "~A" b)))
+ ))
+
+(defmethod cursor-un-init ((cursor sql-cursor) &key (returnpk nil))
+ (setf (cursor-initialized-p cursor) nil)
+ (if returnpk
+ (values nil nil nil nil)
+ (values nil nil nil)))
+
+(clsql::locally-enable-sql-reader-syntax)
+
+(defmethod cursor-init ((cursor sql-cursor))
+ (let* ((sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (con (controller-db sc))
+ (tuples
+ (clsql:select [key]
+ :from [keyvalue]
+ :where [= [clctn_id] (oid (cursor-btree cursor))]
+ :database con
+ ))
+ (len (length tuples)))
+ ;; now we somehow have to load the keys into the array...
+ ;; actually, this should be an adjustable vector...
+ (setf (:sql-crsr-ks cursor) (make-array (length tuples)))
+ (do ((i 0 (1+ i))
+ (tup tuples (cdr tup)))
+ ((= i len) nil)
+ (setf (aref (:sql-crsr-ks cursor) i)
+ (deserialize-from-base64-string (caar tup) :sc sc)))
+ (sort (:sql-crsr-ks cursor) #'my-generic-less-than)
+ (setf (:sql-crsr-ck cursor) 0)
+ (setf (cursor-initialized-p cursor) t)
+ ))
+
+(clsql::restore-sql-reader-syntax-state)
+
+;; we're assuming here that nil is not a legitimate key.
+(defmethod get-current-key ((cursor sql-cursor))
+ (let ((x (:sql-crsr-ck cursor)))
+ (if (and (>= x 0) (< x (length (:sql-crsr-ks cursor))))
+ (svref (:sql-crsr-ks cursor) x)
+ '()
+ ))
+ )
+
+(defmethod get-current-value ((cursor sql-cursor))
+ (let ((key (get-current-key cursor)))
+ (if key
+ (get-value key (cursor-btree cursor))
+ '())))
+
+(defmethod has-key-value ((cursor sql-cursor))
+ (let ((key (get-current-key cursor)))
+ (if key
+ (values t key (get-value key (cursor-btree cursor)))
+ (cursor-un-init cursor))))
+
+
+
+(defmethod cursor-first ((cursor sql-cursor))
+ (declare (optimize (speed 3)))
+ ;; Read all of the keys...
+ ;; We need to get the contoller db from the btree somehow...
+ (cursor-init cursor)
+ (has-key-value cursor)
+ )
+
+
+;;A bit of a hack.....
+
+;; If you run off the end, this can set cursor-initalized-p to nil.
+(defmethod cursor-last ((cursor sql-cursor) )
+ (unless (cursor-initialized-p cursor)
+ (cursor-init cursor))
+ (setf (:sql-crsr-ck cursor)
+ (- (length (:sql-crsr-ks cursor)) 1))
+ (setf (cursor-initialized-p cursor) t)
+ (has-key-value cursor))
+
+
+
+(defmethod cursor-next ((cursor sql-cursor))
+ (if (cursor-initialized-p cursor)
+ (progn
+ (incf (:sql-crsr-ck cursor))
+ (has-key-value cursor))
+ (cursor-first cursor)))
+
+(defmethod cursor-prev ((cursor sql-cursor))
+ (declare (optimize (speed 3)))
+ (if (cursor-initialized-p cursor)
+ (progn
+ (decf (:sql-crsr-ck cursor))
+ (has-key-value cursor))
+ (cursor-last cursor)))
+
+(defmethod cursor-set ((cursor sql-cursor) key)
+ (declare (optimize (speed 3)))
+ (if (cursor-initialized-p cursor)
+ (let ((p (position key (:sql-crsr-ks cursor) :test #'equal)))
+ (if p
+ (progn
+ (setf (:sql-crsr-ck cursor) p)
+ (setf (cursor-initialized-p cursor) t)
+ (has-key-value cursor)
+ )
+ (setf (cursor-initialized-p cursor) nil)))
+ (progn
+ (cursor-init cursor)
+ (let ((p (position key (:sql-crsr-ks cursor) :test #'equal)))
+ (if p
+ (progn
+ (setf (:sql-crsr-ck cursor) p)
+ (has-key-value cursor)
+ )
+ (setf (cursor-initialized-p cursor) nil))))
+ ))
+
+
+(defmethod cursor-set-range ((cursor sql-cursor) key)
+ (declare (optimize (speed 3)))
+ ;; I'm a little fuzzy on when I should leave a cursor in
+ ;; the initialized state...
+ (unless (cursor-initialized-p cursor)
+ (cursor-init cursor))
+ (let ((len (length (:sql-crsr-ks cursor)))
+ (vs '()))
+ (do ((i 0 (1+ i)))
+ ((or (= i len)
+ vs)
+ vs)
+ (progn
+ (multiple-value-bind (h k v)
+ (cursor-next cursor)
+ (when (my-generic-less-than key k)
+ (setf vs t))
+ )
+ ))
+ (if vs
+ (cursor-current cursor)
+ (cursor-un-init cursor))))
+
+
+
+(defmethod cursor-get-both ((cursor sql-cursor) key value)
+ (declare (optimize (speed 3)))
+ (let* ((bt (cursor-btree cursor))
+ (v (get-value key bt)))
+ (if (equal v value)
+;; We need to leave this cursor properly posistioned....
+;; For a secondary cursor it's harder, but for this, it's simple
+ (cursor-set cursor key)
+ (cursor-un-init cursor))))
+
+;; This needs to be rewritten!
+(defmethod cursor-get-both-range ((cursor sql-cursor) key value)
+ (declare (optimize (speed 3)))
+ (let* ((bt (cursor-btree cursor))
+ (v (get-value key bt)))
+ ;; Since we don't allow duplicates in primary cursors, I
+ ;; guess this is all that needs to be done!
+ ;; If there were a test to cover this, the semantics would be clearer...
+ (if (equal v value)
+ (cursor-set cursor key)
+ (cursor-un-init cursor))))
+
+
+
+(defmethod cursor-delete ((cursor sql-cursor))
+ (declare (optimize (speed 3)))
+ (if (cursor-initialized-p cursor)
+ (multiple-value-bind
+ (has k v)
+ (cursor-current cursor)
+ (declare (ignore has v))
+ ;; Now I need to suck the value out of the cursor, somehow....
+ (remove-kv k (cursor-btree cursor)))
+ (error "Can't delete with uninitialized cursor!")))
+
+
+;; This needs to be changed!
+(defmethod cursor-put ((cursor sql-cursor) value &key (key nil key-specified-p))
+ "Put by cursor. Not particularly useful since primaries
+don't support duplicates. Currently doesn't properly move
+the cursor."
+ (declare (optimize (speed 3)))
+ (error "Puts on sql-cursors are not yet implemented, because I can't get them to work on BDB cursors!"))
+
+;; Secondary Cursors
+(defclass sql-secondary-cursor (sql-cursor)
+ (
+ (dup-number :accessor :dp-nmbr :initarg :dup-number :initform 0 :type integer)
+ )
+ (:documentation "Cursor for traversing bdb secondary indices."))
+
+
+(defmethod make-cursor ((bt sql-btree-index))
+ "Make a secondary-cursor from a secondary index."
+ (declare (optimize (speed 3)))
+ (make-instance 'sql-secondary-cursor
+ :btree bt
+ :oid (oid bt)))
+
+
+
+(defmethod has-key-value-scnd ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (let ((ck (:sql-crsr-ck cursor)))
+ (if (and (>= ck 0) (< ck (length (:sql-crsr-ks cursor))))
+ (let* ((cur-pk (aref (:sql-crsr-ks cursor)
+ (:sql-crsr-ck cursor)))
+ (sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (con (controller-db sc))
+ (indexed-pk (sql-get-from-clcn-nth (cursor-oid cursor) cur-pk
+ sc con
+ (:dp-nmbr cursor))))
+ (if indexed-pk
+ (let ((v (get-value indexed-pk (primary (cursor-btree cursor)))))
+ (if v
+ (if returnpk
+ (values t cur-pk v indexed-pk)
+ (values t cur-pk v))
+ (cursor-un-init cursor :returnpk returnpk)))
+ (cursor-un-init cursor :returnpk returnpk)))
+ (progn
+ (cursor-un-init cursor :returnpk returnpk)))))
+
+(defmethod cursor-current ((cursor sql-secondary-cursor) )
+ (cursor-current-x cursor))
+
+(defmethod cursor-current-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (has-key-value-scnd cursor :returnpk returnpk)
+)
+
+(defmethod cursor-pcurrent ((cursor sql-secondary-cursor))
+ (cursor-current-x cursor :returnpk t))
+
+(defmethod cursor-pfirst ((cursor sql-secondary-cursor))
+ (cursor-first-x cursor :returnpk t))
+
+(defmethod cursor-plast ((cursor sql-secondary-cursor))
+ (cursor-last-x cursor :returnpk t))
+
+(defmethod cursor-pnext ((cursor sql-secondary-cursor))
+ (cursor-next-x cursor :returnpk t))
+
+(defmethod cursor-pprev ((cursor sql-secondary-cursor))
+ (cursor-prev-x cursor :returnpk t))
+
+(defmethod cursor-pset ((cursor sql-secondary-cursor) key)
+ (declare (optimize (speed 3)))
+ (unless (cursor-initialized-p cursor)
+ (cursor-init cursor))
+ (let ((idx (position key (:sql-crsr-ks cursor))))
+ (if idx
+ (progn
+ (setf (:sql-crsr-ck cursor) idx)
+ (setf (:dp-nmbr cursor) 0)
+ (cursor-current-x cursor :returnpk t))
+ (cursor-un-init cursor)
+ )))
+
+(defun array-index-if (p a)
+ (do ((i 0 (1+ i)))
+ ((or (not (array-in-bounds-p a i))
+ (funcall p (aref a i)))
+ (if (funcall p (aref a i))
+ i
+ -1)))
+)
+
+(defmethod cursor-pset-range ((cursor sql-secondary-cursor) key)
+ (declare (optimize (speed 3)))
+ (unless (cursor-initialized-p cursor)
+ (cursor-init cursor))
+ (let ((idx (array-index-if #'(lambda (x) (my-generic-less-than key x)) (:sql-crsr-ks cursor))))
+ (if (<= 0 idx)
+ (progn
+ (setf (:sql-crsr-ck cursor) idx)
+ (setf (:dp-nmbr cursor) 0)
+ (cursor-current-x cursor :returnpk t)
+ )
+ (cursor-un-init cursor :returnpk t)
+ )))
+
+
+;; Moves the cursor to a the first secondary key / primary key pair,
+;; with secondary key equal to the key argument, and primary key greater or equal to the pkey argument.
+;; Returns has-tuple / secondary key / value / primary key.
+(defmethod cursor-pget-both ((cursor sql-secondary-cursor) key pkey)
+ (declare (optimize (speed 3)))
+;; It's better to get the value by the primary key,
+;; as that is unique..
+ (let* ((bt (primary (cursor-btree cursor)))
+ (v (get-value pkey bt)))
+;; Now, bascially we set the cursor to the key and
+;; andvance it until we get the value that we want...
+ (if v
+ (do ((vs
+ (multiple-value-list (cursor-set cursor key))
+ (multiple-value-list (cursor-next cursor))))
+ ((or (null (car vs)) ;; We ran off the end..
+ (not (equal key (cadr vs))) ;; We ran out of values matching this key..
+ (equal v (caddr vs))) ;; we found what we are loodking for!
+;; our return condition...
+ (if (equal v (caddr vs))
+ (cursor-current-x cursor :returnpk t)
+ (cursor-un-init cursor :returnpk t))
+ )
+ ;; Here's a body that's nice for debugging...
+ )
+;; If we don't get a value, we have to un-init this cursor...
+ (cursor-un-init cursor :returnpk t))))
+
+(defmethod cursor-pget-both-range ((cursor sql-secondary-cursor) key pkey)
+ (declare (optimize (speed 3)))
+ ;; It's better to get the value by the primary key,
+ ;; as that is unique..
+ (do ((vs
+ (append (multiple-value-list (cursor-set cursor key)) (list pkey))
+ (multiple-value-list (cursor-next-x cursor :returnpk t))))
+ ((or (null (car vs)) ;; We ran off the end..
+ (not (equal key (cadr vs))) ;; We ran out of values matching this key..
+ (equal pkey (caddr vs)) ;; we found what we are loodking for!
+ (my-generic-less-than ;; we went beond the pkey
+ pkey
+ (cadddr vs)
+ )
+ )
+ ;; our return condition...
+ (if (or (equal pkey (caddr vs))
+ (my-generic-less-than ;; we went beond the pkey
+ pkey
+ (cadddr vs)
+ ))
+ (cursor-current-x cursor :returnpk t)
+ (cursor-un-init cursor :returnpk t))
+ )
+ ))
+
+
+(defmethod cursor-delete ((cursor sql-secondary-cursor))
+ "Delete by cursor: deletes ALL secondary indices."
+ (declare (optimize (speed 3)))
+ (if (cursor-initialized-p cursor)
+ (multiple-value-bind
+ (m k v p)
+ (cursor-current-x cursor :returnpk t)
+ (declare (ignore m k v))
+ (remove-kv p (primary (cursor-btree cursor)))
+ (let ((ck (:sql-crsr-ck cursor))
+ (dp (:dp-nmbr cursor)))
+
+ (cursor-next cursor)
+;; Now that we point to the old slot, remove the old slot from the array...
+ (setf (:sql-crsr-ks cursor)
+ (remove-indexed-element-and-adjust
+ ck
+ (:sql-crsr-ks cursor)))
+ ;; now move us back to where we were
+ (cursor-prev cursor)
+ ))
+ (error "Can't delete with uninitialized cursor!")))
+
+(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))
+ (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))
+ (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))
+ (error "Puts are forbidden on secondary indices. Try adding to the primary."))
+
+
+(defmethod cursor-first ((cursor sql-secondary-cursor))
+ (cursor-first-x cursor)
+ )
+
+(defmethod cursor-first-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (declare (optimize (speed 3)))
+ (setf (:dp-nmbr cursor) 0)
+ (cursor-init cursor)
+ (has-key-value-scnd cursor :returnpk returnpk)
+ )
+
+(defmethod cursor-next ((cursor sql-secondary-cursor))
+ (cursor-next-x cursor)
+)
+
+(defmethod cursor-next-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (if (cursor-initialized-p cursor)
+ (progn
+ (let ((cur-pk (get-current-key cursor)))
+ (incf (:sql-crsr-ck cursor))
+ (if (equal cur-pk (get-current-key cursor))
+ (incf (:dp-nmbr cursor))
+ (setf (:dp-nmbr cursor) 0))
+ (has-key-value-scnd cursor :returnpk returnpk)))
+ (cursor-first-x cursor :returnpk returnpk)))
+
+(defmethod cursor-prev ((cursor sql-secondary-cursor))
+ (cursor-prev-x cursor)
+)
+(defmethod cursor-prev-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (declare (optimize (speed 3)))
+ (if (cursor-initialized-p cursor)
+ (progn
+ (let ((cur-pk (get-current-key cursor)))
+ (decf (:sql-crsr-ck cursor))
+ (if (equal cur-pk (get-current-key cursor))
+ (decf (:dp-nmbr cursor))
+ (setf (:dp-nmbr cursor)
+ (sql-get-from-clcn-cnt (cursor-oid cursor)
+ (get-current-key cursor)
+ (controller-db (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+
+ ))))
+ (has-key-value-scnd cursor :returnpk returnpk))
+ (cursor-last-x cursor :returnpk returnpk)))
+
+(defmethod cursor-next-dup ((cursor sql-secondary-cursor))
+ (cursor-next-dup-x cursor)
+)
+
+(defmethod cursor-pnext-dup ((cursor sql-secondary-cursor))
+ (cursor-next-dup-x cursor :returnpk t)
+)
+
+(defmethod cursor-next-dup-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (declare (optimize (speed 3)))
+ (when (cursor-initialized-p cursor)
+ (let* ((cur-pk (aref (:sql-crsr-ks cursor)
+ (:sql-crsr-ck cursor)))
+ (nxt-pk (aref (:sql-crsr-ks cursor)
+ (+ 1 (:sql-crsr-ck cursor))))
+ )
+ (if (equal cur-pk nxt-pk)
+ (progn
+ (incf (:dp-nmbr cursor))
+ (incf (:sql-crsr-ck cursor))
+ (has-key-value-scnd cursor :returnpk returnpk))
+ (progn
+ (setf (:dp-nmbr cursor) 0)
+ (cursor-un-init cursor :returnpk returnpk)
+ )))))
+
+(defmethod cursor-next-nodup ((cursor sql-secondary-cursor))
+ (cursor-next-nodup-x cursor)
+)
+(defmethod cursor-next-nodup-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (if (cursor-initialized-p cursor)
+ (let ((n
+ (do ((i (:sql-crsr-ck cursor) (1+ i)))
+ ((not (equal (aref (:sql-crsr-ks cursor) i)
+ (aref (:sql-crsr-ks cursor) (+ 1 i)))) (+ 1 i)))))
+ (setf (:sql-crsr-ck cursor) n)
+ (setf (:dp-nmbr cursor) 0)
+ (has-key-value-scnd cursor :returnpk returnpk))
+ (cursor-first-x cursor :returnpk returnpk)
+ ))
+
+(defmethod cursor-last ((cursor sql-secondary-cursor))
+ (cursor-last-x cursor)
+)
+(defmethod cursor-last-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (unless (cursor-initialized-p cursor)
+ (cursor-init cursor))
+ (setf (:sql-crsr-ck cursor)
+ (- (length (:sql-crsr-ks cursor)) 1))
+ (setf (:dp-nmbr cursor)
+ (- (sql-get-from-clcn-cnt
+ (cursor-oid cursor)
+ (get-current-key cursor)
+ (controller-db (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ )
+ 1))
+ (assert (>= (:dp-nmbr cursor) 0))
+ (setf (cursor-initialized-p cursor) t)
+ (has-key-value-scnd cursor :returnpk returnpk)
+)
+
+
+
+(defmethod cursor-prev-nodup ((cursor sql-secondary-cursor))
+ (cursor-prev-nodup-x cursor)
+)
+(defmethod cursor-prev-nodup-x ((cursor sql-secondary-cursor) &key (returnpk nil))
+ (declare (optimize (speed 3)))
+ (if (cursor-initialized-p cursor)
+ (progn
+ (setf (:sql-crsr-ck cursor) (- (:sql-crsr-ck cursor) (+ 1 (:dp-nmbr cursor))))
+ (setf (:dp-nmbr cursor)
+ (- (sql-get-from-clcn-cnt (cursor-oid cursor)
+ (get-current-key cursor)
+ (controller-db (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+) 1))
+ (has-key-value-scnd cursor :returnpk returnpk))
+ (cursor-last-x cursor :returnpk returnpk)))
+
+
+(defmethod cursor-pnext-nodup ((cursor sql-secondary-cursor))
+ (cursor-next-nodup-x cursor :returnpk t))
+
+(defmethod cursor-pprev-nodup ((cursor sql-secondary-cursor))
+ (cursor-prev-nodup-x cursor :returnpk t))
Index: elephant/src/sql-controller.lisp
diff -u /dev/null elephant/src/sql-controller.lisp:1.2
--- /dev/null Wed Nov 23 18:51:46 2005
+++ elephant/src/sql-controller.lisp Wed Nov 23 18:51:38 2005
@@ -0,0 +1,650 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; sql-controller.lisp -- Interface to a CLSQL based object store.
+;;;
+;;; Initial version 10/12/2005 by Robert L. Read
+;;; <read at robertlread.net>
+;;;
+;;; part of
+;;;
+;;; Elephant: an object-oriented database for Common Lisp
+;;;
+;;; Copyright (c) 2005 by Robert L. Read
+;;;
+;;; This program is released under the following license
+;;; ("GPL"). For differenct licensing terms, contact the
+;;; copyright holders.
+;;;
+;;; This program is free software; you can redistribute it
+;;; and/or modify it under the terms of the GNU General
+;;; Public License as published by the Free Software
+;;; Foundation; either version 2 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the
+;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
+;;; PARTICULAR PURPOSE. See the GNU General Public License
+;;; for more details.
+;;;
+;;; The GNU General Public License can be found in the file
+;;; LICENSE which should have been distributed with this
+;;; code. It can also be found at
+;;;
+;;; http://www.opensource.org/licenses/gpl-license.php
+;;;
+;;; You should have received a copy of the GNU General
+;;; Public License along with this program; if not, write
+;;; to the Free Software Foundation, Inc., 59 Temple Place,
+;;; Suite 330, Boston, MA 02111-1307 USA
+;;;
+
+(in-package "ELEPHANT")
+
+;;; other clsql packages would have to be added for
+;;; non-postgresql databases, see the CL-SQL documentation
+(eval-when ( :compile-toplevel :load-toplevel)
+ (asdf:oos 'asdf:load-op :clsql)
+
+;; 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*)
+
+;; (asdf:oos 'asdf:load-op :clsql-postgresql-socket)
+ )
+
+(defmacro with-transaction-sql ((&key
+ (store-controller-sql '*store-controller*))
+ &body body)
+ "Execute a body with a transaction in place. On success,
+the transaction is committed. Otherwise, the transaction is
+aborted. If the body deadlocks, the body is re-executed in
+a new transaction, retrying a fixed number of iterations.
+*auto-commit* is false for the body of the transaction."
+ `(if (typep ,store-controller-sql 'elephant::sql-store-controller)
+ (if (clsql::in-transaction-p
+ :database
+ (controller-db ,store-controller-sql))
+ (progn
+ , at body)
+ (prog2
+ (clsql::set-autocommit nil)
+ (clsql::with-transaction
+ (:database
+ (controller-db ,store-controller-sql))
+ , at body)
+ (clsql::set-autocommit t)
+ ))))
+
+(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" "")
+ )
+ )
+ (: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)
+ )
+
+(defmethod get-transaction-macro-symbol ((sc sql-store-controller))
+ 'with-transaction-sql
+ )
+
+
+(defun sql-test-and-construct (spec)
+ (if (sql-store-spec-p spec)
+ (open-store-sql spec)
+ nil)
+ )
+
+(eval-when ( :load-toplevel)
+ (register-strategy 'sql-test-and-construct)
+ )
+
+(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 , at 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)
+ (
+ )
+ (:documentation "A SQL implementation of a BTree"))
+
+(defmethod get-value (key (bt sql-btree))
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc)))
+ (sql-get-from-clcn (oid bt) key sc con)))
+
+
+(defmethod existsp (key (bt sql-btree))
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc)))
+ (sql-from-clcn-existsp (oid bt) key con)
+ )
+ )
+
+(defmethod (setf get-value) (value key (bt sql-btree))
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc)))
+ (sql-add-to-clcn (oid bt) key value sc con)
+ )
+ )
+(defmethod remove-kv (key (bt sql-btree))
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc)))
+ (sql-remove-one-from-clcn (oid bt)
+ key
+ sc
+ con))
+ )
+
+
+;; Because these things are transient, I can't move them
+;; 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-cache :accessor indices-cache :initform (make-hash-table)
+ :transient t)
+ )
+ (:metaclass persistent-metaclass)
+ (:documentation "A SQL-based BTree that supports secondary indices."))
+
+(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
+ ))
+
+(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
+ ))
+
+
+;; 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..
+(defmethod add-index ((bt sql-indexed-btree) &key index-name key-form populate)
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (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)))
+ (setf (gethash index-name (indices-cache bt)) index)
+ (setf (gethash index-name indices) index)
+ (setf (indices bt) indices)
+ (when populate
+ (let ((key-fn (key-fn index))
+ )
+ (with-transaction-sql (:store-controller-sql sc)
+ (map-btree
+ #'(lambda (k v)
+ (multiple-value-bind (index? secondary-key)
+ (funcall key-fn index k v)
+;; This is a slow, DB cycle intensive operation. It could chunked somehow,
+;; I think, probably making it 10 times faster.
+ (when index?
+ (sql-add-to-clcn (oid index)
+ secondary-key
+ k
+ sc con :insert-only t)
+ )))
+ bt))))
+ index)
+ (error "Invalid index initargs!"))))
+
+
+
+(defmethod (setf get-value) (value key (bt sql-indexed-btree))
+ "Set a key / value pair, and update secondary indices."
+ (let* ((sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc))
+ (indices (indices-cache bt)))
+ (with-transaction-sql (:store-controller-sql sc)
+ (maphash
+ #'(lambda (k index)
+ (multiple-value-bind (index? secondary-key)
+ (funcall (key-fn index) index key value)
+ (when index?
+ (sql-add-to-clcn (oid index)
+ secondary-key
+ key
+ sc con :insert-only t)
+ )))
+ indices)
+ ;; Now we place the actual value
+ (sql-add-to-clcn (oid bt) key value sc con)
+ )
+ value))
+
+(defmethod remove-kv (key (bt sql-indexed-btree))
+ "Remove a key / value pair, and update secondary indices."
+ (declare (optimize (speed 3)))
+ (let* (
+ (sc (check-con (:dbcn-spc-pst bt)))
+ (con (controller-db sc)))
+ (with-transaction-sql (:store-controller-sql sc)
+ (let ((value (get-value key bt)))
+ (when value
+ (let ((indices (indices-cache bt)))
+ (maphash
+ #'(lambda (k index)
+ (multiple-value-bind (index? secondary-key)
+ (funcall (key-fn index) index key value)
+ (when index?
+ ;; This function will in fact remove all of the
+ ;; duplicate keys; but this is not how the BDB system works.
+ ;; It appears to me, based on the behavior of tests, that
+ ;; this should remove the FIRST row that match not all.
+ (sql-remove-key-and-value-from-clcn (oid index)
+ secondary-key
+ key
+ con)
+ ;; And furthermore, we have to remove the index entry
+ ;; (remove-kv secondary-key index)
+ )))
+ indices)
+ ;; Now we place the actual value
+ (sql-remove-from-clcn (oid bt) key sc con))
+ )
+ value))))
+
+
+
+(defclass sql-btree-index (btree-index sql-btree)
+ ()
+ (:metaclass persistent-metaclass)
+ (:documentation "A SQL-based BTree supports secondary indices."))
+
+
+(clsql::locally-enable-sql-reader-syntax)
+
+;; Check that the table exists and is in proper form.
+;; If it is not in proper form, signal an error, no
+;; way to recover from that automatically. If it
+;; does not exist, return nil so we can create it later!
+
+;; These functions are probably not cross-database portable...
+(defun keyvalue-table-exists (con)
+ ;; we want to use ":owner :all" because we don't really care who created
+ ;; the table, as long as we have the rights we need!
+ (clsql:table-exists-p [keyvalue] :database con :owner :all)
+ )
+
+;; This is just an initial version; it is possible that
+;; we might someday wish to use blobs instead; certainly, I am
+;; storing blobs now in the Berkeley-db and we meed to make sure
+;; we are properly testing that. However, blobs are awkward to
+;; handle, so I am going to do this first...
+(defun create-keyvalue-table (con)
+ ;; the "serial" specifiation here does not seem to work, (
+ ;; apparently not supported by clsql, so I have to execute these
+ ;; commands specifically. This may be a database-dependent way of doing
+ ;; things, but sequences in general are NOT standardized across RDBMS.
+ ;; I prefer sequence to support the "get-next-oid" command, but there
+ ;; ARE other ways of doing it that could make this more portable.
+ ;; (execute-command create :database con)
+ ;; (execute-command idx-id :database con)
+ ;; (execute-command idx-key :database con)
+ ;; Danger: Rather than use 'serial as a type, CLSQL appears to support
+ ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem!
+
+ ;; ALL OF THIS needs to be inside a transaction.
+ (clsql::create-table [keyvalue]
+ '(
+ ([clctn_id] integer :not-null)
+ ([key] text :not-null)
+ ([value] text)
+ ) :database con
+ )
+ ;; :constraints '("PRIMARY KEY (clctn_id key)"
+ ;; "UNIQUE (clctn_id,key)")
+
+ ;; 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)
+ ;;)
+ ;; (unless (index-exists-p [idx_clctn_id])
+ (clsql::create-index [idx_clctn_id] :on [keyvalue]
+ :attributes '([clctn_id])
+ :database con)
+ ;; )
+ ;; (unless (index-exists-p [idx_key])
+ (clsql::create-index [idx_key] :on [keyvalue]
+ :attributes '([key])
+ :database con)
+ ;;)
+ ;; This is actually unique
+ ;; (unless (index-exists-p [idx_both])
+ (clsql:create-index [idx_both] :on [keyvalue]
+ :attributes '([clctn_id] [key])
+ :database con)
+ ;;)
+ )
+
+
+(defmethod open-controller ((sc sql-store-controller)
+ ;; At present these three have no meaning
+ &key
+ (recover nil)
+ (recover-fatal nil)
+ (thread t))
+ (the sql-store-controller
+ (let* ((dbtype (car (:dbcn-spc sc)))
+ (con (clsql:connect (cdr (:dbcn-spc sc))
+;; WARNING: This line of code forces us to use postgresql.
+;; If this were parametrized upwards we could concievably try
+;; other backends.
+ :database-type dbtype
+;; 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..
+ ;; This kind of thing is typically database-specific, but at least we
+ ;; can put it in a function....
+ (unless (keyvalue-table-exists con)
+ (create-keyvalue-table con))
+ (setf (slot-value sc 'root) (make-sql-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)
+ 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
+ ;; (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 ))
+ (let ((con (controller-db sc)))
+ (clsql:sequence-next [persistent_seq]
+ :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
+;; file. If we can introduce a layer of class indirectio there, then
+;; we can control things properly. In the meantime, I will implement
+;; 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)
+ (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
+ &key (insert-only nil))
+ (let (
+ (vbs
+ (serialize-to-base64-string value))
+ (kbs
+ (serialize-to-base64-string key))
+ )
+ (if (and (not insert-only) (sql-from-clcn-existsp clcn key con))
+ (clsql::update-records [keyvalue]
+ :av-pairs `((key ,kbs)
+ (clctn_id ,clcn)
+ (value ,vbs))
+ :where [and [= [clctn_id] clcn] [= [key] kbs]]
+ :database con)
+ (clsql::insert-records :into [keyvalue]
+ :attributes '(key clctn_id value)
+ :values (list kbs clcn vbs)
+ :database con
+ ))
+ )
+ value
+ )
+
+
+
+(defmethod 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
+;; SQL by nature returns a set of values (when the keys aren't unique.)
+;;
+;; I serious problem here is what to do if the things aren't unique.
+;; According to the Elepahnt documentation, you should get one value
+;; (not clear which one, the "first" probably, and then use a
+;; cursor to iterate over duplicates.
+;; So although it is moderately clear how the cursor is supposed to
+;; work, I'm not sure how I'm supposed to know what value should be
+;; returend by this non-cursor function.
+;; I suspect if I return the value that has the lowest OID, that will
+;; match the behavior of the sleepycat function....
+;; 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)
+ (sql-get-from-clcn-nth clcn key sc con 0)
+ )
+(defmethod sql-get-from-clcn-nth ((clcn integer) key sc con (n integer))
+ (let* (
+ (kbs
+ (serialize-to-base64-string key))
+ (tuples
+ (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;
+ ;; this isn't a very good way to do things...
+ ;; Note also that this will be extremely inefficient if
+ ;; you have for example, a boolean index function.
+ ;; I could parametrize this routine to take an "nth"
+ ;; parameter. But there is almost no way to implement
+ ;; that efficiently without changing the database structure;
+ ;; but that's OK, I could add a column to support that
+ ;; relatively easily later on.
+ (if (< n (length tuples))
+ (values (nth n (sort
+ (mapcar
+ #'(lambda (x)
+ (deserialize-from-base64-string (car x) :sc sc))
+ tuples)
+ #'my-generic-less-than))
+ t)
+ (values nil nil))))
+
+(defmethod sql-get-from-clcn-cnt ((clcn integer) key con)
+ (let* (
+ (kbs (serialize-to-base64-string key))
+ (tuples
+ (clsql::select [count [value]]
+ :from [keyvalue]
+ :where [and [= [clctn_id] clcn] [= [key] kbs]]
+ :database con
+ )))
+ (caar tuples)))
+
+(defmethod sql-dump-clcn ((clcn integer) sc con)
+ (let* (
+ (tuples
+ (clsql::select [key] [value]
+ :from [keyvalue]
+ :where [and [= [clctn_id] clcn]]
+ :database con
+ )))
+ (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string :sc sc)) x))
+ tuples)))
+
+(defmethod sql-from-root-existsp (key con)
+ (sql-from-clcn-existsp 0 key con)
+ )
+
+(defmethod sql-from-clcn-existsp ((clcn integer) key con)
+ (let* (
+ (kbs (with-buffer-streams (out-buf)
+ (serialize-to-base64-string key))
+ )
+ (tuples
+ (clsql::select [value]
+ :from [keyvalue]
+ :where [and [= [clctn_id] clcn] [= [key] kbs]]
+ :database con
+ )))
+ (if tuples
+ t
+ nil)
+ ))
+
+(defmethod sql-remove-from-root (key sc con)
+ (sql-remove-from-clcn 0 key sc con)
+ )
+
+(defmethod sql-remove-from-clcn ((clcn integer) key sc con)
+ (let (
+ (kbs (serialize-to-base64-string key))
+ )
+ (clsql::delete-records :from [keyvalue]
+ :where [and [= [clctn_id] clcn] [= [key] kbs]]
+ :database con
+ ))
+ )
+(defmethod sql-remove-one-from-clcn ((clcn integer) key sc con)
+ (let* (
+ (kbs (serialize-to-base64-string key))
+ ;; We want to remove the FIRST value, based on our ordering.
+ ;; have little choice but to read everything in and delete based on
+ ;; the "value field".
+ (tuples
+ (clsql::select [value]
+ :from [keyvalue]
+ :where [and [= [clctn_id] clcn] [= [key] kbs]]
+ :database con
+ )))
+ (if (< (length tuples) 1)
+ nil
+ (let ((to-remove
+ (serialize-to-base64-string
+ (nth 0 (sort
+ (mapcar
+ #'(lambda (x)
+ (deserialize-from-base64-string (car x) :sc sc))
+ tuples)
+ #'my-generic-less-than)))))
+ (clsql::delete-records :from [keyvalue]
+ :where [and [= [clctn_id] clcn] [= [key] kbs]
+ [= [value] to-remove]]
+ :database con
+ )
+ )
+ )
+ ))
+
+(defmethod sql-remove-key-and-value-from-clcn ((clcn integer) key value con)
+ (let* (
+ (kbs (serialize-to-base64-string key))
+ (vbs (serialize-to-base64-string value)))
+ (clsql::delete-records :from [keyvalue]
+ :where [and [= [clctn_id] clcn] [= [key] kbs]
+ [= [value] vbs]]
+ :database con
+ )
+ ))
+
+(clsql::restore-sql-reader-syntax-state)
+
+
+
+
+(defmethod persistent-slot-writer-aux ((sc sql-store-controller) new-value instance name)
+ (let* ((con (controller-db sc)))
+ (sql-add-to-root
+ (form-slot-key (oid instance) name)
+ new-value
+ sc con)
+ ))
+
+;; This was almost ncecessary to allow this functionality to be included
+;; only if you load ele-clsql. It could also be used in bdb, and probably
+;; should be, but there is some strange macro stuff there that I am afraid
+;; to change, so I am implementing it only here.
+(defmethod persistent-slot-reader-aux ((sc sql-store-controller) instance name)
+ (let* ((con (controller-db sc)))
+ (multiple-value-bind (v existsp)
+ (sql-get-from-root
+ (form-slot-key (oid instance) name)
+ sc con)
+ (if existsp
+ v
+ (error 'unbound-slot :instance instance :name name))))
+ )
+
+(defmethod persistent-slot-boundp-aux ((sc sql-store-controller) instance name)
+ (let* ((con (controller-db sc)))
+ (if (sql-from-root-existsp
+ (form-slot-key (oid instance) name)
+ con )
+ t nil)))
+
+
+
Index: elephant/src/sql-tutorial.lisp
diff -u /dev/null elephant/src/sql-tutorial.lisp:1.2
--- /dev/null Wed Nov 23 18:51:46 2005
+++ elephant/src/sql-tutorial.lisp Wed Nov 23 18:51:38 2005
@@ -0,0 +1,116 @@
+(asdf:operate 'asdf:load-op :elephant)
+(asdf:operate 'asdf:load-op :ele-bdb)
+(asdf:operate 'asdf:load-op :elephant-tests)
+(in-package "ELEPHANT-TESTS")
+(open-store *testdb-path*)
+(add-to-root "my key" "my value")
+(get-from-root "my key")
+
+(setq foo (cons nil nil))
+
+(add-to-root "my key" foo)
+(add-to-root "my other key" foo)
+(eq (get-from-root "my key")
+ (get-from-root "my other key"))
+
+(setf (car foo) T)
+
+(get-from-root "my key")
+
+(defclass my-persistent-class ()
+ ((slot1 :accessor slot1)
+ (slot2 :accessor slot2))
+ (:metaclass persistent-metaclass))
+
+
+(setq foo (make-instance 'my-persistent-class))
+
+(add-to-root "foo" foo)
+
+(add-to-root "bar" foo)
+
+(eq (get-from-root "foo")
+ (get-from-root "bar"))
+
+(get-from-root "foo")
+(setf (slot1 foo) "one")
+
+(setf (slot2 foo) "two")
+(slot1 foo)
+(slot2 foo)
+(setf (slot1 foo) "three")
+
+(slot1 (get-from-root "bar"))
+
+(setq *auto-commit* nil)
+(with-transaction ()
+ (setf (slot1 foo) 123456789101112)
+ (setf (slot2 foo) "onetwothree..."))
+
+(defvar *friends-birthdays* (make-btree))
+
+(add-to-root "friends-birthdays" *friends-birthdays*)
+
+(setf (get-value "Andrew" *friends-birthdays*)
+ (encode-universal-time 0 0 0 22 12 1976))
+(setf (get-value "Ben" *friends-birthdays*)
+ (encode-universal-time 0 0 0 14 4 1976))
+
+(get-value "Andrew" *friends-birthdays*)
+(decode-universal-time *)
+(defvar curs (make-cursor *friends-birthdays*))
+ (cursor-close curs)
+(setq curs (make-cursor *friends-birthdays*))
+(cursor-current curs)
+(cursor-first curs)
+(cursor-next curs)
+(cursor-next curs)
+(cursor-close curs)
+(with-transaction ()
+ (with-btree-cursor (curs *friends-birthdays*)
+ (loop
+ (multiple-value-bind (more k v) (cursor-next curs)
+ (unless more (return nil))
+ (format t "~A ~A~%" k v)))))
+
+(defclass appointment ()
+ ((date :accessor ap-date :initarg :date :type integer)
+ (type :accessor ap-type :initarg :type :type string))
+ (:metaclass persistent-metaclass))
+
+(defvar *appointments* (with-transaction () (make-indexed-btree *store-controller*)))
+
+(defun add-appointment (date type)
+ (with-transaction ()
+ (setf (get-value date *appointments*)
+ (make-instance 'appointment :date date :type type))))
+
+(add-appointment (encode-universal-time 0 0 0 22 12 2004) "Birthday")
+(add-appointment (encode-universal-time 0 0 0 14 4 2005) "Birthday")
+(add-appointment (encode-universal-time 0 0 0 1 1 2005) "Holiday")
+(defun key-by-type (secondary-db primary value)
+ (declare (ignore secondary-db primary))
+ (let ((type (ap-type value)))
+ (when type
+ (values t type))))
+(with-transaction ()
+ (add-index *appointments* :index-name 'by-type
+ :key-form 'key-by-type
+ :populate t))
+(defvar *by-type* (get-index *appointments* 'by-type))
+
+(decode-universal-time (ap-date (get-value "Holiday" *by-type*)))
+
+
+(with-btree-cursor (curs *by-type*)
+ (loop for (more? k v) =
+ (multiple-value-list (cursor-set curs "Birthday"))
+ then (multiple-value-list (cursor-next-dup curs))
+ do
+ (unless more? (return t))
+ (multiple-value-bind (s m h d mo y)
+ (decode-universal-time (ap-date v))
+ (declare (ignore s m h))
+ (format t "~A/~A/~A~%" mo d y))))
+
+
Index: elephant/src/classes.lisp
diff -u elephant/src/classes.lisp:1.13 elephant/src/classes.lisp:1.14
--- elephant/src/classes.lisp:1.13 Thu Feb 24 02:07:52 2005
+++ elephant/src/classes.lisp Wed Nov 23 18:51:37 2005
@@ -45,13 +45,31 @@
(defmethod initialize-instance :before ((instance persistent)
&rest initargs
- &key from-oid)
+ &key from-oid
+ spec
+ ;; Putting the default use
+ ;; of the global variable here
+ ;; is very bad for testing and multi-repository
+ ;; use; it is, however, good for making
+ ;; things work exactly the way they originally did!
+ (sc *store-controller*))
"Sets the OID."
(declare (ignore initargs))
+
+;; This lines are fundamentally valuable in making sure that
+;; we hvae completely specified things.
+;; (if (null sc)
+;; (break))
(if (not from-oid)
- (setf (oid instance) (next-oid *store-controller*))
+ (setf (oid instance) (next-oid sc))
(setf (oid instance) from-oid))
- (cache-instance *store-controller* instance))
+ (if (not spec)
+ (if (not (typep sc 'bdb-store-controller))
+ (setf (:dbcn-spc-pst instance) (:dbcn-spc sc))
+ (setf (:dbcn-spc-pst instance) (controller-path sc))
+ )
+ (setf (:dbcn-spc-pst instance) spec))
+ (cache-instance sc instance))
(defclass persistent-object (persistent)
()
@@ -141,7 +159,7 @@
(flet ((persistent-slot-p (item)
(member item persistent-slot-names :test #'eq)))
(let ((transient-slot-inits
- (if (eq slot-names t) ; t means all slots
+ (if (eq slot-names t) ; t means all slots
(transient-slot-names class)
(remove-if #'persistent-slot-p slot-names)))
(persistent-slot-inits
@@ -150,23 +168,27 @@
;; initialize the persistent slots
(flet ((initialize-from-initarg (slot-def)
(loop for initarg in initargs
- with slot-initargs = (slot-definition-initargs slot-def)
- when (member initarg slot-initargs :test #'eq)
- do
- (setf (slot-value-using-class class instance slot-def)
- (getf initargs initarg))
- (return t))))
+ with slot-initargs = (slot-definition-initargs slot-def)
+ when (member initarg slot-initargs :test #'eq)
+ do
+ (setf (slot-value-using-class class instance slot-def)
+ (getf initargs initarg))
+ (return t))))
(loop for slot-def in (class-slots class)
- unless (initialize-from-initarg slot-def)
- when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
- unless (slot-boundp-using-class class instance slot-def)
- do
- (let ((initfun (slot-definition-initfunction slot-def)))
- (when initfun
- (setf (slot-value-using-class class instance slot-def)
- (funcall initfun))))))
- ;; let the implementation initialize the transient slots
- (apply #'call-next-method instance transient-slot-inits initargs)))))
+ unless
+ (initialize-from-initarg slot-def)
+ when
+ (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
+ unless
+ (slot-boundp-using-class class instance slot-def)
+ do
+ (let ((initfun (slot-definition-initfunction slot-def)))
+ (when initfun
+ (setf (slot-value-using-class class instance slot-def)
+ (funcall initfun))))
+ )
+ ;; let the implementation initialize the transient slots
+ (apply #'call-next-method instance transient-slot-inits initargs))))))
(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
;; probably should delete discarded slots, but we'll worry about that later
@@ -237,14 +259,26 @@
(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Deletes the slot from the database."
- (declare (optimize (speed 3)))
- (with-buffer-streams (key-buf)
- (buffer-write-int (oid instance) key-buf)
- (serialize (slot-definition-name slot-def) key-buf)
- (db-delete-buffered
- (controller-db *store-controller*) key-buf
- :transaction *current-transaction*
- :auto-commit *auto-commit*))
+ (declare (optimize (speed 3))
+ (ignore class))
+ (if (sql-store-spec-p (:dbcn-spc-pst instance))
+ (progn
+ (let* ((sc (check-con (:dbcn-spc-pst instance)))
+ (con (controller-db sc)))
+ (sql-remove-from-root
+ (form-slot-key (oid instance) (slot-definition-name slot-def))
+ sc
+ con
+ )
+ ))
+ (with-buffer-streams (key-buf)
+ (buffer-write-int (oid instance) key-buf)
+ (serialize (slot-definition-name slot-def) key-buf)
+ (db-delete-buffered
+ (controller-db (check-con (:dbcn-spc-pst instance))) key-buf
+ :transaction *current-transaction*
+ :auto-commit *auto-commit*))
+ )
instance)
#+allegro
@@ -253,4 +287,4 @@
until (eq (slot-definition-name slot) slot-name)
finally (if (typep slot 'persistent-slot-definition)
(slot-makunbound-using-class class instance slot)
- (call-next-method))))
\ No newline at end of file
+ (call-next-method))))
Index: elephant/src/collections.lisp
diff -u elephant/src/collections.lisp:1.11 elephant/src/collections.lisp:1.12
--- elephant/src/collections.lisp:1.11 Sat Sep 25 20:57:37 2004
+++ elephant/src/collections.lisp Wed Nov 23 18:51:37 2005
@@ -48,10 +48,36 @@
(:documentation "Abstract superclass of all collection types."))
;;; btree access
-(defclass btree (persistent-collection) ()
+(defclass btree (persistent-collection)
+
+;; I don't like having to put this here, as this is only used by
+;; the extending class indexed-btree. But I can't figure out
+;; how to make the :transient flag work on that class without
+;; creating a circularity in the class presidence list...
+(
+)
(:documentation "A hash-table like interface to a BTree,
which stores things in a semi-ordered fashion."))
+(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.
+(defun make-bdb-btree (sc)
+ (let ((bt (make-instance 'bdb-btree :sc sc)))
+ (setf (:dbcn-spc-pst bt) (controller-path sc))
+ bt)
+ )
+
+;; somehow these functions need to be part of our strategy,
+;; or better yet methods on the store-controller.
+
+
+
(defgeneric get-value (key bt)
(:documentation "Get a value from a Btree."))
@@ -61,45 +87,128 @@
(defgeneric remove-kv (key bt)
(:documentation "Remove a key / value pair from a BTree."))
-(defmethod get-value (key (bt btree))
+(defmethod get-value (key (bt bdb-btree))
(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-btrees *store-controller*)
+ (controller-btrees
+ (check-con (:dbcn-spc-pst bt))
+;; *store-controller*
+ )
key-buf value-buf)))
- (if buf (values (deserialize buf) T)
+ (if buf (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) T)
(values nil nil)))))
-(defmethod (setf get-value) (value key (bt btree))
+(defmethod existsp (key (bt bdb-btree))
+ (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-btrees (check-con (:dbcn-spc-pst bt)))
+ key-buf value-buf)))
+ (if buf t
+ nil))))
+
+
+(defmethod (setf get-value) (value key (bt bdb-btree))
(declare (optimize (speed 3)))
(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 *store-controller*)
+ (db-put-buffered (controller-btrees (check-con (:dbcn-spc-pst bt)))
key-buf value-buf
:auto-commit *auto-commit*)
value))
-(defmethod remove-kv (key (bt btree))
+(defmethod remove-kv (key (bt bdb-btree))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
- (db-delete-buffered (controller-btrees *store-controller*)
+ (db-delete-buffered (controller-btrees (check-con (:dbcn-spc-pst bt)))
key-buf :auto-commit *auto-commit*)))
;; Secondary indices
-(defclass indexed-btree (btree)
- ((indices :accessor indices :initform (make-hash-table))
+ (defclass indexed-btree ()
+ (
+ )
+ (:documentation "A BTree which supports 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))
+ :transient t
+)
+ )
(:metaclass persistent-metaclass)
- (:documentation "A BTree which supports secondary indices."))
+ (:documentation "A BDB-based BTree supports secondary indices."))
+
+
+(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)
+ )
+
+(defun btree-differ (x y)
+ (let ((cx1 (make-cursor x))
+ (cy1 (make-cursor y))
+ (done nil)
+ (rv nil)
+ (mx nil)
+ (kx nil)
+ (vx nil)
+ (my nil)
+ (ky nil)
+ (vy nil))
+ (cursor-first cx1)
+ (cursor-first cy1)
+ (do ((i 0 (1+ i)))
+ (done nil)
+ (multiple-value-bind (m k v) (cursor-current cx1)
+ (setf mx m)
+ (setf kx k)
+ (setf vx v))
+ (multiple-value-bind (m k v) (cursor-current cy1)
+ (setf my m)
+ (setf ky k)
+ (setf vy v))
+ (if (not (and (equal mx my)
+ (equal kx ky)
+ (equal vx vy)))
+ (setf rv (list mx my kx ky vx vy)))
+ (setf done (and (not mx) (not mx))
+ )
+ (cursor-next cx1)
+ (cursor-next cy1)
+ )
+ (cursor-close cx1)
+ (cursor-close cy1)
+ rv
+ ))
+
(defmethod shared-initialize :after ((instance indexed-btree) slot-names
&rest rest)
@@ -124,39 +233,47 @@
(defgeneric remove-index (bt index-name)
(:documentation "Remove a named index."))
-(defmethod add-index ((bt indexed-btree) &key index-name key-form populate)
- (if (and (not (null index-name))
- (symbolp index-name) (or (symbolp key-form) (listp key-form)))
- (let ((indices (indices bt))
- (index (make-instance 'btree-index :primary bt
- :key-form key-form)))
- (setf (gethash index-name (indices-cache bt)) index)
- (setf (gethash index-name indices) index)
- (setf (indices bt) indices)
- (when populate
- (let ((key-fn (key-fn index)))
- (with-buffer-streams (primary-buf secondary-buf)
- (with-transaction ()
- (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 *store-controller*)
- secondary-buf primary-buf)
- (reset-buffer-stream primary-buf)
- (reset-buffer-stream secondary-buf))))
- bt)))))
- index)
- (error "Invalid index initargs!")))
-
+(defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate)
+ (let ((sc (check-con (:dbcn-spc-pst 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 get-index ((bt indexed-btree) index-name)
(gethash index-name (indices-cache bt)))
@@ -166,65 +283,75 @@
(remhash index-name indices)
(setf (indices bt) indices)))
-(defmethod (setf get-value) (value key (bt indexed-btree))
+(defmethod (setf get-value) (value key (bt bdb-indexed-btree))
"Set a key / value pair, and update secondary indices."
- (declare (optimize (speed 3)))
- (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 ()
- (db-put-buffered (controller-btrees *store-controller*)
- 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?
- (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 *store-controller*)
- secondary-buf key-buf)
- (reset-buffer-stream secondary-buf))))
- value))))
-
-(defmethod remove-kv (key (bt indexed-btree))
- "Remove a key / value pair, and update secondary indices."
- (declare (optimize (speed 3)))
- (with-buffer-streams (key-buf secondary-buf)
- (buffer-write-int (oid bt) key-buf)
- (serialize key key-buf)
- (with-transaction ()
- (let ((value (get-value key bt)))
- (when value
- (let ((indices (indices-cache bt)))
- (loop
- for index being the hash-value of indices
+ (let ((sc (check-con (:dbcn-spc-pst 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?
(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
- (sleepycat::db-delete-kv-buffered
- (controller-indices *store-controller*)
- secondary-buf key-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))))
- (db-delete-buffered (controller-btrees *store-controller*)
- key-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 (check-con (:dbcn-spc-pst 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
+ (sleepycat::db-delete-kv-buffered
+ (controller-indices (check-con (:dbcn-spc-pst bt)))
+ secondary-buf key-buf)
+ (reset-buffer-stream secondary-buf))))
+ (db-delete-buffered (controller-btrees (check-con (:dbcn-spc-pst bt)))
+ key-buf))))))))
+;; This also needs to build the correct kind of index, and
+;; be the correct kind of btree...
(defclass btree-index (btree)
((primary :type indexed-btree :reader primary :initarg :primary)
- (key-form :reader key-form :initarg :key-form)
+ (key-form :reader key-form :initarg :key-form :initform nil)
(key-fn :type function :accessor key-fn :transient t))
(:metaclass persistent-metaclass)
(:documentation "Secondary index to an indexed-btree."))
+
+(defclass bdb-btree-index (btree-index bdb-btree )
+ ()
+ (:metaclass persistent-metaclass)
+ (:documentation "A BDB-based BTree supports secondary indices."))
+
(defmethod shared-initialize :after ((instance btree-index) slot-names
&rest rest)
(declare (ignore slot-names rest))
@@ -233,16 +360,18 @@
(setf (key-fn instance) (fdefinition key-form))
(setf (key-fn instance) (compile nil key-form)))))
-(defmethod get-value (key (bt btree-index))
+;; 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 *store-controller*)
+ (controller-indices-assoc (check-con (:dbcn-spc-pst bt)))
key-buf value-buf)))
- (if buf (values (deserialize buf) T)
+ (if buf (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) T)
(values nil nil)))))
(defmethod (setf get-value) (value key (bt btree-index))
@@ -260,11 +389,11 @@
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
- (controller-indices *store-controller*)
+ (controller-indices (check-con (:dbcn-spc-pst bt)))
key-buf value-buf)))
(if buf
(let ((oid (buffer-read-fixnum buf)))
- (values (deserialize buf) oid))
+ (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) oid))
(values nil nil)))))
(defmethod remove-kv (key (bt btree-index))
@@ -275,18 +404,39 @@
;; 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 cursor ()
- ((handle :accessor cursor-handle :initarg :handle)
+ (
(oid :accessor cursor-oid :type fixnum :initarg :oid)
+
+;; (intialized-p cursor) means that the cursor has
+;; a legitimate position, not that any initialization
+;; action has been taken. The implementors of this abstract class
+;; should make sure that happens under the sheets...
+;; According to my understanding, cursors are initialized
+;; when you invoke an operation that sets them to something
+;; (such as cursor-first), and are uninitialized if you
+;; move them in such a way that they no longer have a legimtimate
+;; value.
(initialized-p :accessor cursor-initialized-p
:type boolean :initform nil :initarg :initialized-p)
(btree :accessor cursor-btree :initarg :btree))
(:documentation "A cursor for traversing (primary) BTrees."))
+(defclass bdb-cursor (cursor)
+ (
+ (handle :accessor cursor-handle :initarg :handle)
+ )
+ (:documentation "A cursor for traversing (primary) BDB-BTrees."))
+
+
(defgeneric make-cursor (bt)
(:documentation "Construct a cursor for traversing BTrees."))
+
(defgeneric cursor-close (cursor)
(:documentation
"Close the cursor. Make sure to close cursors before the
@@ -352,14 +502,15 @@
"Put by cursor. Currently doesn't properly move the
cursor."))
-(defmethod make-cursor ((bt btree))
+(defmethod make-cursor ((bt bdb-btree))
"Make a cursor from a btree."
(declare (optimize (speed 3)))
- (make-instance 'cursor
+ (make-instance 'bdb-cursor
:btree bt
- :handle (db-cursor (controller-btrees *store-controller*))
+ :handle (db-cursor (controller-btrees (check-con (:dbcn-spc-pst bt))))
:oid (oid bt)))
+
(defmacro with-btree-cursor ((var bt) &body body)
"Macro which opens a named cursor on a BTree (primary or
not), evaluates the forms, then closes the cursor."
@@ -375,13 +526,17 @@
(multiple-value-bind (more k v) (cursor-next curs)
(unless more (return nil))
(funcall fn k v)))))
+(defun dump-btree (bt)
+ (format t "DUMP ~A~%" bt)
+ (map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt)
+ )
-(defmethod cursor-close ((cursor cursor))
+(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 cursor))
+(defmethod cursor-duplicate ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(make-instance (type-of cursor)
:initialized-p (cursor-initialized-p cursor)
@@ -390,7 +545,7 @@
(cursor-handle cursor)
:position (cursor-initialized-p cursor))))
-(defmethod cursor-current ((cursor cursor))
+(defmethod cursor-current ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -399,10 +554,13 @@
:current t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-first ((cursor cursor))
+(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)
@@ -411,11 +569,14 @@
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) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
;;A bit of a hack.....
-(defmethod cursor-last ((cursor cursor))
+(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)
@@ -429,7 +590,10 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor) key-buf
@@ -437,10 +601,13 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-next ((cursor cursor))
+(defmethod cursor-next ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -448,11 +615,12 @@
(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) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-first cursor)))
-(defmethod cursor-prev ((cursor cursor))
+(defmethod cursor-prev ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -460,11 +628,12 @@
(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) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-last cursor)))
-(defmethod cursor-set ((cursor cursor) key)
+(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)
@@ -474,10 +643,10 @@
key-buf value-buf :set t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val)))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-set-range ((cursor cursor) key)
+(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)
@@ -487,10 +656,11 @@
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) (deserialize val)))
+ (values t (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-get-both ((cursor cursor) key value)
+(defmethod cursor-get-both ((cursor bdb-cursor) key value)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -505,7 +675,7 @@
(values t key value))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-get-both-range ((cursor cursor) key value)
+(defmethod cursor-get-both-range ((cursor bdb-cursor) key value)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -516,10 +686,10 @@
key-buf value-buf :get-both-range t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize v)))
+ (values t key (deserialize v :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-delete ((cursor cursor))
+(defmethod cursor-delete ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -530,11 +700,12 @@
(when (and key (= (buffer-read-int key) (cursor-oid cursor)))
;; in case of a secondary index this should delete everything
;; as specified by the BDB docs.
- (remove-kv (deserialize key) (cursor-btree cursor)))
+ (remove-kv (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (cursor-btree cursor)))
(setf (cursor-initialized-p cursor) nil)))
(error "Can't delete with uninitialized cursor!")))
-(defmethod cursor-put ((cursor cursor) value &key (key nil key-specified-p))
+(defmethod cursor-put ((cursor bdb-cursor) value &key (key nil key-specified-p))
"Put by cursor. Not particularly useful since primaries
don't support duplicates. Currently doesn't properly move
the cursor."
@@ -548,7 +719,9 @@
value-buf :current t)
(declare (ignore v))
(if (and k (= (buffer-read-int k) (cursor-oid cursor)))
- (setf (get-value (deserialize k) (cursor-btree cursor))
+ (setf (get-value
+ (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (cursor-btree cursor))
value)
(setf (cursor-initialized-p cursor) nil))))
(error "Can't put with uninitialized cursor!"))))
@@ -558,6 +731,9 @@
(defclass secondary-cursor (cursor) ()
(:documentation "Cursor for traversing secondary indices."))
+(defclass bdb-secondary-cursor (bdb-cursor) ()
+ (:documentation "Cursor for traversing bdb secondary indices."))
+
(defgeneric cursor-pcurrent (cursor)
(:documentation
"Returns has-tuple / secondary key / value / primary key
@@ -639,16 +815,18 @@
different key.) Returns has-tuple / secondary key / value /
primary key."))
-(defmethod make-cursor ((bt btree-index))
+
+(defmethod make-cursor ((bt bdb-btree-index))
"Make a secondary-cursor from a secondary index."
(declare (optimize (speed 3)))
- (make-instance 'secondary-cursor
+ (make-instance 'bdb-secondary-cursor
:btree bt
:handle (db-cursor
- (controller-indices-assoc *store-controller*))
+ (controller-indices-assoc (check-con (:dbcn-spc-pst bt))))
:oid (oid bt)))
-(defmethod cursor-pcurrent ((cursor secondary-cursor))
+
+(defmethod cursor-pcurrent ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -658,11 +836,17 @@
:current t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)
+ (values t
+ (deserialize
+ key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize
+ val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pfirst ((cursor secondary-cursor))
+(defmethod cursor-pfirst ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -671,12 +855,14 @@
key-buf pkey-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) (deserialize val)
+ (values t
+(deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+(deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey))))
(setf (cursor-initialized-p cursor) nil)))))
;;A bit of a hack.....
-(defmethod cursor-plast ((cursor secondary-cursor))
+(defmethod cursor-plast ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (+ (cursor-oid cursor) 1) key-buf)
@@ -690,9 +876,11 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)
+ (values t
+ (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey)
- (deserialize pkey))))
+ (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil))))
(multiple-value-bind (key pkey val)
(db-cursor-pmove-buffered (cursor-handle cursor) key-buf
@@ -700,11 +888,12 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pnext ((cursor secondary-cursor))
+(defmethod cursor-pnext ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -712,12 +901,15 @@
(db-cursor-pmove-buffered (cursor-handle cursor)
key-buf pkey-buf value-buf :next t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey)))
(setf (cursor-initialized-p cursor) nil))))
(cursor-pfirst cursor)))
-(defmethod cursor-pprev ((cursor secondary-cursor))
+(defmethod cursor-pprev ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -725,12 +917,15 @@
(db-cursor-pmove-buffered (cursor-handle cursor)
key-buf pkey-buf value-buf :prev t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey)))
(setf (cursor-initialized-p cursor) nil))))
(cursor-plast cursor)))
-(defmethod cursor-pset ((cursor secondary-cursor) key)
+(defmethod cursor-pset ((cursor bdb-secondary-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -740,11 +935,11 @@
key-buf pkey-buf value-buf :set t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey))))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-pset-range ((cursor secondary-cursor) key)
+(defmethod cursor-pset-range ((cursor bdb-secondary-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -754,11 +949,12 @@
key-buf pkey-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) (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey))))
+ (values t (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-pget-both ((cursor secondary-cursor) key pkey)
+(defmethod cursor-pget-both ((cursor bdb-secondary-cursor) key pkey)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(let ((primary-oid (oid (primary (cursor-btree cursor)))))
@@ -772,10 +968,10 @@
(declare (ignore p))
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val) pkey))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) pkey))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pget-both-range ((cursor secondary-cursor) key pkey)
+(defmethod cursor-pget-both-range ((cursor bdb-secondary-cursor) key pkey)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(let ((primary-oid (oid (primary (cursor-btree cursor)))))
@@ -788,11 +984,11 @@
pkey-buf value-buf :get-both-range t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val)
- (progn (buffer-read-int p) (deserialize p))))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int p) (deserialize p :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-delete ((cursor secondary-cursor))
+(defmethod cursor-delete ((cursor bdb-secondary-cursor))
"Delete by cursor: deletes ALL secondary indices."
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
@@ -804,30 +1000,31 @@
(when (and key (= (buffer-read-int key) (cursor-oid cursor))
(= (buffer-read-int pkey) (oid (primary
(cursor-btree cursor)))))
- (remove-kv (deserialize pkey) (primary (cursor-btree cursor))))
+ (remove-kv (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (primary (cursor-btree cursor))))
(setf (cursor-initialized-p cursor) nil)))
(error "Can't delete with uninitialized cursor!")))
-(defmethod cursor-get-both ((cursor secondary-cursor) key value)
+(defmethod cursor-get-both ((cursor bdb-secondary-cursor) key value)
"cursor-get-both not implemented for secondary indices.
Use cursor-pget-both."
(declare (ignore cursor key value))
(error "cursor-get-both not implemented on secondary
indices. Use cursor-pget-both."))
-(defmethod cursor-get-both-range ((cursor secondary-cursor) key value)
+(defmethod cursor-get-both-range ((cursor bdb-secondary-cursor) key value)
"cursor-get-both-range not implemented for secondary indices.
Use cursor-pget-both-range."
(declare (ignore cursor key value))
(error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range."))
-(defmethod cursor-put ((cursor secondary-cursor) value &rest rest)
+(defmethod cursor-put ((cursor bdb-secondary-cursor) value &rest rest)
"Puts are forbidden on secondary indices. Try adding to
the primary."
(declare (ignore rest value cursor))
(error "Puts are forbidden on secondary indices. Try adding to the primary."))
-(defmethod cursor-next-dup ((cursor secondary-cursor))
+(defmethod cursor-next-dup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -835,10 +1032,11 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :next-dup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-next-nodup ((cursor secondary-cursor))
+(defmethod cursor-next-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -846,11 +1044,12 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :next-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-first cursor)))
-(defmethod cursor-prev-nodup ((cursor secondary-cursor))
+(defmethod cursor-prev-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -858,11 +1057,12 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :prev-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-last cursor)))
-(defmethod cursor-pnext-dup ((cursor secondary-cursor))
+(defmethod cursor-pnext-dup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -870,11 +1070,12 @@
(db-cursor-pmove-buffered (cursor-handle cursor)
key-buf pkey-buf value-buf :next-dup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey)))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pnext-nodup ((cursor secondary-cursor))
+(defmethod cursor-pnext-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -882,12 +1083,13 @@
(db-cursor-pmove-buffered (cursor-handle cursor) key-buf
pkey-buf value-buf :next-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey)))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-pfirst cursor)))
-(defmethod cursor-pprev-nodup ((cursor secondary-cursor))
+(defmethod cursor-pprev-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -895,8 +1097,10 @@
(db-cursor-pmove-buffered (cursor-handle cursor) key-buf
pkey-buf value-buf :prev-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey)))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey)
+ (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-plast cursor)))
Index: elephant/src/controller.lisp
diff -u elephant/src/controller.lisp:1.12 elephant/src/controller.lisp:1.13
--- elephant/src/controller.lisp:1.12 Thu Feb 24 02:06:10 2005
+++ elephant/src/controller.lisp Wed Nov 23 18:51:37 2005
@@ -42,20 +42,47 @@
(in-package "ELEPHANT")
+
+;; This list contains functions that take one arugment,
+;; the "spec", and will construct an appropriate store
+;; controller from it.
+(defvar *strategies* '())
+
+(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant-0.3/")
+
+(defun register-strategy (spec-to-controller)
+ (setq *strategies* (delete spec-to-controller *strategies*))
+ (setq *strategies* (cons spec-to-controller *strategies*))
+ )
+
+(defun get-controller (spec)
+ (let ((store-controllers nil))
+ (dolist (s *strategies*)
+ (let ((sc (funcall s spec)))
+ (if sc
+ (push sc store-controllers))))
+ (if (not (= (length store-controllers) 1))
+ (error "Strategy resolution for this spec completely failed!")
+ (car store-controllers))
+ ))
+
+
(defclass store-controller ()
+ ;; purely abstract class doesn't need a slot, though it
+ ;; should take the common ones.
((path :type (or pathname string)
:accessor controller-path
:initarg :path)
+ (root :reader controller-root)
+ (db :type (or null pointer-void) :accessor controller-db :initform '())
(environment :type (or null pointer-void)
:accessor controller-environment)
- (db :type (or null pointer-void) :accessor controller-db)
(oid-db :type (or null pointer-void) :accessor controller-oid-db)
(oid-seq :type (or null pointer-void) :accessor controller-oid-seq)
(btrees :type (or null pointer-void) :accessor controller-btrees)
(indices :type (or null pointer-void) :accessor controller-indices)
(indices-assoc :type (or null pointer-void)
:accessor controller-indices-assoc)
- (root :reader controller-root)
(instance-cache :accessor instance-cache
:initform (make-cache-table :test 'eql)))
(:documentation "Class of objects responsible for the
@@ -63,6 +90,35 @@
creation, counters, locks, the root (for garbage collection,)
et cetera."))
+(defclass bdb-store-controller (store-controller)
+ (
+ )
+ (: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."))
+
+;; Without somemore sophistication, these functions
+;; need to be defined here, so that they will be available for testing
+;; even if you do not use the strategy in question...
+(defun bdb-store-spec-p (path)
+ (stringp path))
+
+(defun sql-store-spec-p (path)
+ (listp path))
+
+
+;; This has now way of passing in optionals?
+(defun bdb-test-and-construct (spec)
+ (if (bdb-store-spec-p spec)
+ (open-store-bdb spec)
+ nil)
+ )
+
+(eval-when ( :load-toplevel)
+ (register-strategy 'bdb-test-and-construct)
+ )
+
(defgeneric open-controller (sc &key recover recover-fatal thread)
(:documentation
"Opens the underlying environment and all the necessary
@@ -73,6 +129,118 @@
"Close the db handles and environment. Tries to wipe out
references to the db handles."))
+(defgeneric build-btree (sc)
+ (:documentation
+ "Construct a btree of the appropriate type corresponding to this store-controller."))
+
+(defgeneric build-indexed-btree (sc)
+ (:documentation
+ "Construct a btree of the appropriate type corresponding to this store-controller."))
+
+(defgeneric get-transaction-macro-symbol (sc)
+ (:documentation
+ "Return the strategy-specific macro symbol that will let you do a transaction within that macro."))
+
+
+(defun make-indexed-btree (&optional (sc *store-controller*))
+ (build-indexed-btree sc)
+ )
+
+
+(defgeneric build-btree-index (sc &key primary key-form)
+ (:documentation
+ "Construct a btree of the appropriate type corresponding to this store-controller."))
+
+(defgeneric copy-from-key (key src dst)
+ (:documentation
+ "Move the object identified by key on the root in the src to the dst."))
+
+(defmethod copy-from-key (key src dst)
+ (let ((v (get-from-root key :store-controller src)))
+ (if v
+ (add-to-root key v :store-controller dst)
+ v))
+ )
+
+(defun copy-btree-contents (src dst)
+ (map-btree
+ #'(lambda (k v)
+ (setf (get-value k dst) v)
+ )
+ src)
+ )
+
+;; I don't know if I need a "deeper" copy here or not....
+(defun my-copy-hash-table (ht)
+ (let ((nht (make-hash-table)))
+ (maphash
+ #'(lambda (k v)
+ (setf (gethash k nht) v))
+ ht)
+ nht)
+ )
+
+(defun add-index-from-index (iname v dstibt dstsc)
+ (declare (type btree-index v)
+ (type indexed-btree dstibt))
+ (let ((kf (key-form v)))
+ (format t " kf ~A ~%" kf)
+ (let ((index
+ (build-btree-index dstsc :primary dstibt
+ :key-form kf)))
+ ;; Why do I have to do this here?
+ (setf (indices dstibt) (make-hash-table))
+ (setf (indices-cache dstibt) (make-hash-table))
+ (setf (gethash iname (indices-cache dstibt)) index)
+ (setf (gethash iname (indices dstibt)) index)
+ )
+ )
+ )
+
+(defun my-copy-indices (ht dst dstsc)
+ (maphash
+ #'(lambda (k v)
+ (add-index-from-index k v dst dstsc))
+ ht)
+ )
+
+(defmethod migrate ((dst store-controller) obj)
+ "Copy a currently persistent object to a new repository."
+ (if (typep obj 'btree)
+ ;; For a btree, we need to copy the object with the indices intact,
+ ;; then just read it out...
+ (if (typep obj 'indexed-btree)
+ ;; We have to copy the indexes..
+ (let ((nobj (build-indexed-btree dst)))
+ (my-copy-indices (indices obj) nobj dst)
+ (copy-btree-contents obj nobj)
+ nobj
+ )
+ (let ((nobj (build-btree dst)))
+ (copy-btree-contents obj nobj)
+ nobj)
+ )
+ (error (format nil "the migrate function cannot migrate objects like ~A~%" obj)
+ )))
+
+;; ;; This routine attempst to do a destructive migration
+;; ;; of the object to the new repository
+(defmethod migraten-pobj ((dst store-controller) obj copy-fn)
+ "Migrate a persistent object and apply a binary (lambda (dst src) ...) function to the new object."
+ ;; The simplest thing to do here is to make
+ ;; an object of the new class;
+ ;; we will make it the responsibility of the caller to
+ ;; perform the copy on the slots --- or
+ ;; we can force them to pass in this function.
+ (if (typep obj 'persistent)
+ (let ((nobj (make-instance (type-of obj) :sc dst)))
+ (apply copy-fn (list nobj obj))
+ nobj)
+ (error (format "obj ~A is not a persistent object!~%" obj))
+ )
+ )
+
+
(defun add-to-root (key value &key (store-controller *store-controller*))
"Add an arbitrary persistent thing to the root, so you can
retrieve it in a later session. N.B. this means it (and
@@ -85,6 +253,13 @@
(declare (type store-controller store-controller))
(get-value key (controller-root store-controller)))
+(defun from-root-existsp (key &key (store-controller *store-controller*))
+ "Get a something from the root."
+ (declare (type store-controller store-controller))
+ (if (existsp key (controller-root store-controller))
+ t
+ nil))
+
(defun remove-from-root (key &key (store-controller *store-controller*))
"Remove something from the root."
(declare (type store-controller store-controller))
@@ -104,14 +279,14 @@
;; Should get cached since make-instance calls cache-instance
(make-instance class-name :from-oid oid))))
-(defun next-oid (sc)
+(defmethod next-oid ((sc bdb-store-controller))
"Get the next OID."
- (declare (type store-controller sc))
+ (declare (type bdb-store-controller sc))
(db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+
:auto-commit t :txn-nosync t))
;; Open/close
-(defmethod open-controller ((sc store-controller) &key (recover nil)
+(defmethod open-controller ((sc bdb-store-controller) &key (recover nil)
(recover-fatal nil) (thread t))
(let ((env (db-env-create)))
;; thread stuff?
@@ -124,6 +299,7 @@
(indices (db-create env))
(indices-assoc (db-create env)))
(setf (controller-db sc) db)
+ (setf (gethash (controller-path sc) *dbconnection-spec*) sc)
(db-open db :file "%ELEPHANT" :database "%ELEPHANTDB"
:auto-commit t :type DB-BTREE :create t :thread thread)
@@ -160,11 +336,11 @@
:auto-commit t :create t :thread t)
(setf (controller-oid-seq sc) oid-seq)))
- (let ((root (make-instance 'btree :from-oid -1)))
+ (let ((root (make-instance 'bdb-btree :from-oid -1 :sc sc)))
(setf (slot-value sc 'root) root))
sc)))
-(defmethod close-controller ((sc store-controller))
+(defmethod close-controller ((sc bdb-store-controller))
(when (slot-value sc 'root)
;; no root
(setf (slot-value sc 'root) nil)
@@ -187,6 +363,49 @@
(setf (controller-environment sc) nil)
nil))
+;; Do these things need to take &rest arguments?
+(defmethod build-btree ((sc bdb-store-controller))
+ (make-bdb-btree sc)
+ )
+
+
+(defun make-btree (&optional (sc *store-controller*))
+ (build-btree sc)
+ )
+
+(defmethod get-transaction-macro-symbol ((sc bdb-store-controller))
+ 'with-transaction
+ )
+
+(defun open-store (spec &key (recover nil)
+ (recover-fatal nil) (thread t))
+ "Conveniently open a store controller."
+ (setq *store-controller*
+ (get-controller spec))
+ (open-controller *store-controller* :recover recover
+ :recover-fatal recover-fatal :thread thread))
+
+(defun open-store-bdb (spec &key (recover nil)
+ (recover-fatal nil) (thread t))
+ "Conveniently open a store controller."
+ (setq *store-controller*
+ (if (bdb-store-spec-p spec)
+ (make-instance 'bdb-store-controller :path spec)
+ (error (format nil "uninterpretable path/spec specifier: ~A" spec))))
+ (open-controller *store-controller* :recover recover
+ :recover-fatal recover-fatal :thread thread))
+
+
+(defmacro with-open-store-bdb ((path) &body body)
+ "Executes the body with an open controller,
+ unconditionally closing the controller on exit."
+ `(let ((*store-controller* (make-instance 'bdb-store-controller :path ,path)))
+ (declare (special *store-controller*))
+ (open-controller *store-controller*)
+ (unwind-protect
+ (progn , at body)
+ (close-controller *store-controller*))))
+
(defmacro with-open-controller ((&optional (sc '*store-controller*))
&body body)
"Executes body with the specified controller open, closing
@@ -198,34 +417,37 @@
, at body))
(close-controller ,sc)))
-(defun open-store (path &key (recover nil)
- (recover-fatal nil) (thread t))
- "Conveniently open a store controller."
- (setq *store-controller* (make-instance 'store-controller :path path))
- (open-controller *store-controller* :recover recover
- :recover-fatal recover-fatal :thread thread))
-
(defun close-store ()
"Conveniently close the store controller."
- (close-controller *store-controller*))
+ (if *store-controller*
+ (close-controller *store-controller*)))
-(defmacro with-open-store ((path) &body body)
+(defmacro with-open-store ((spec) &body body)
"Executes the body with an open controller,
unconditionally closing the controller on exit."
- `(let ((*store-controller* (make-instance 'store-controller :path ,path)))
- (declare (special *store-controller*))
- (open-controller *store-controller*)
- (unwind-protect
- (progn , at body)
- (close-controller *store-controller*))))
+ `(let ((*store-controller*
+ (get-controller ,spec)))
+ (declare (special *store-controller*))
+;; (open-controller *store-controller*)
+ (unwind-protect
+ (progn , at body)
+ (close-controller *store-controller*))))
+
;;; Make these respect the transaction keywords (e.g. degree-2)
-(defun start-transaction (&key (parent *current-transaction*))
- "Start a transaction. May be nested but not interleaved."
- (vector-push-extend *current-transaction* *transaction-stack*)
- (setq *current-transaction*
- (db-transaction-begin (controller-environment *store-controller*)
- :parent parent)))
+;; (defun start-transaction (&key (parent *current-transaction*))
+;; "Start a transaction. May be nested but not interleaved."
+;; (vector-push-extend *current-transaction* *transaction-stack*)
+;; (setq *current-transaction*
+;; (db-transaction-begin (controller-environment *store-controller*)
+;; :parent parent)))
+
+(defun start-ele-transaction (&key (parent *current-transaction*) (store-controller *store-controller*))
+ "Start a transaction. May be nested but not interleaved."
+ (vector-push-extend *current-transaction* *transaction-stack*)
+ (setq *current-transaction*
+ (db-transaction-begin (controller-environment store-controller)
+ :parent parent)))
(defun commit-transaction ()
"Commit the current transaction."
@@ -236,3 +458,12 @@
"Abort the current transaction."
(db-transaction-abort)
(setq *current-transaction* (vector-pop *transaction-stack*)))
+
+(defgeneric persistent-slot-reader-aux (sc instance name)
+ (:documentation
+ "Auxilliary method to allow implementation-specific slot reading"))
+
+(defgeneric persistent-slot-writer-aux (sc new-value instance name)
+ (:documentation
+ "Auxilliary method to allow implementation-specific slot writing"))
+
Index: elephant/src/elephant.lisp
diff -u elephant/src/elephant.lisp:1.14 elephant/src/elephant.lisp:1.15
--- elephant/src/elephant.lisp:1.14 Thu Feb 24 02:07:52 2005
+++ elephant/src/elephant.lisp Wed Nov 23 18:51:37 2005
@@ -49,20 +49,49 @@
(:use common-lisp sleepycat uffi)
(:shadow #:with-transaction)
(:export #:*store-controller* #:*current-transaction* #:*auto-commit*
+ #:bdb-store-controller
+ #:sql-store-controller
+ #:make-bdb-btree
+ #:make-sql-btree
+ #:bdb-indexed-btree
+ #:sql-indexed-btree
+ #:from-root-existsp
#:open-store #:close-store #:with-open-store
#:store-controller #:open-controller #:close-controller
#:with-open-controller #:controller-path #:controller-environment
#:controller-db #:controller-root
#:add-to-root #:get-from-root #:remove-from-root
#:start-transaction #:commit-transaction #:abort-transaction
+ #:start-ele-transaction #:commit-transaction #:abort-transaction
+ #:build-btree
+ #:make-btree
+ #:make-indexed-btree
+ #:copy-from-key
+ #:open-store-bdb
+ #:open-store-sql
+ #:btree-differ
+ #:migrate
+ #:persistent-slot-boundp-sql
+ #:persistent-slot-reader-sql
+ #:persistent-slot-writer-sql
+ #:*elephant-lib-path*
+
#:persistent #:persistent-object #:persistent-metaclass
- #:persistent-collection #:btree #:get-value #:remove-kv
+ #:persistent-collection #:btree
+ #:bdb-btree #:sql-btree
+ #:get-value #:remove-kv
+
#:indexed-btree #:add-index #:get-index #:remove-index
#:btree-index #:get-primary-key
#:indices #:primary #:key-form #:key-fn
+ #:build-indexed-btree
+ #:make-indexed-btree
+
+ #:bdb-cursor #:sql-cursor
+ #:cursor-init
#:cursor #:secondary-cursor #:make-cursor
#:with-btree-cursor #:map-btree #:cursor-close
#:cursor-duplicate #:cursor-current #:cursor-first
@@ -249,4 +278,4 @@
#+cmu
(eval-when (:compile-toplevel)
- (proclaim '(optimize (ext:inhibit-warnings 3))))
\ No newline at end of file
+ (proclaim '(optimize (ext:inhibit-warnings 3))))
Index: elephant/src/libsleepycat.c
diff -u elephant/src/libsleepycat.c:1.11 elephant/src/libsleepycat.c:1.12
--- elephant/src/libsleepycat.c:1.11 Thu Feb 24 02:04:13 2005
+++ elephant/src/libsleepycat.c Wed Nov 23 18:51:37 2005
@@ -58,6 +58,11 @@
#include <string.h>
#include <wchar.h>
+/* Some utility stuff used to be here but has been placed in
+ libmemutil.c */
+
+/* Pointer arithmetic utility functions */
+/* should these be in network-byte order? probably not..... */
/* Pointer arithmetic utility functions */
/* should these be in network-byte order? probably not..... */
int read_int(char *buf, int offset) {
Index: elephant/src/metaclasses.lisp
diff -u elephant/src/metaclasses.lisp:1.7 elephant/src/metaclasses.lisp:1.8
--- elephant/src/metaclasses.lisp:1.7 Thu Feb 24 02:07:52 2005
+++ elephant/src/metaclasses.lisp Wed Nov 23 18:51:37 2005
@@ -42,8 +42,43 @@
(in-package "ELEPHANT")
+(defvar *dbconnection-spec*
+ (make-hash-table :test 'equal))
+
+(defun connection-is-indeed-open (con)
+ t ;; I don't yet know how to implement this
+ )
+
+;; This needs to be a store-controller method...
+(defun check-con (spec &optional sc )
+ (let ((con (gethash spec *dbconnection-spec*)))
+ (if (and con (connection-is-indeed-open con))
+ con
+ (if (not (typep sc 'bdb-store-controller))
+ (progn
+ (error "We can't default to *store-controller* in a multi-use enviroment."))
+ ;; (setf (gethash spec *dbconnection-spec*)
+ ;; (clsql:connect (cdr (:dbcn-spc sc))
+ ;; :database-type :postgresql-socket
+ ;; :if-exists :old)))
+ (error "We don't know how to open a bdb-connection here!")
+ ;; if they don't give us connection-spec, we can't reopen things...
+ ))))
+
+
+
(defclass persistent ()
- ((%oid :accessor oid :initarg :from-oid))
+ ((%oid :accessor oid :initarg :from-oid)
+ ;; This is just an idea for storing connections in the persistent
+ ;; objects; these should be transient as well, if that flag exists!
+ ;; In the case of sleepy cat, this is the controller-db from
+ ;; the store-controller. In the case of SQL this is
+ ;; the connection spec (since the connection might be broken?)
+ ;; It probably would be better to put a string in here in the case
+ ;; of sleepycat...
+ (dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst
+ :initform '())
+ )
(:documentation
"Abstract superclass for all persistent classes (common
to user-defined classes and collections.)"))
@@ -65,7 +100,12 @@
(cdr (%persistent-slots class)))
(defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list)
- (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class)))))
+;; (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class)))))
+ (setf (%persistent-slots class) (cons new-slot-list
+ (if (slot-boundp class '%persistent-slots)
+ (car (%persistent-slots class))
+ nil)
+ )))
(defclass persistent-slot-definition (standard-slot-definition)
())
@@ -155,8 +195,8 @@
(defmethod compute-effective-slot-definition-initargs ((class slots-class)
direct-slots)
(let* ((name (loop for s in direct-slots
- when s
- do (return (slot-definition-name s))))
+ when s
+ do (return (slot-definition-name s))))
(initer (dolist (s direct-slots)
(when (%slot-definition-initfunction s)
(return s))))
@@ -184,7 +224,7 @@
(defun ensure-transient-chain (slot-definitions initargs)
(declare (ignore initargs))
(loop for slot-definition in slot-definitions
- always (transient slot-definition)))
+ always (transient slot-definition)))
(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions)
(let ((initargs (call-next-method)))
@@ -194,19 +234,22 @@
(setf (getf initargs :allocation) :database)
initargs))))
+
(defmacro persistent-slot-reader (instance name)
- `(progn
- (with-buffer-streams (key-buf value-buf)
- (buffer-write-int (oid ,instance) key-buf)
- (serialize ,name key-buf)
- (let ((buf (db-get-key-buffered
- (controller-db *store-controller*)
- key-buf value-buf)))
- (if buf (deserialize buf)
- #+cmu
- (error 'unbound-slot :instance ,instance :slot ,name)
- #-cmu
- (error 'unbound-slot :instance ,instance :name ,name))))))
+`(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance)))
+ (persistent-slot-reader-aux (check-con (:dbcn-spc-pst ,instance)) ,instance ,name)
+ (progn
+ (with-buffer-streams (key-buf value-buf)
+ (buffer-write-int (oid ,instance) key-buf)
+ (serialize ,name key-buf)
+ (let ((buf (db-get-key-buffered
+ (controller-db (check-con (:dbcn-spc-pst ,instance)))
+ key-buf value-buf)))
+ (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst instance)))
+ #+cmu
+ (error 'unbound-slot :instance ,instance :slot ,name)
+ #-cmu
+ (error 'unbound-slot :instance ,instance :name ,name)))))))
#+(or cmu sbcl)
(defun make-persistent-reader (name)
@@ -216,16 +259,18 @@
(persistent-slot-reader instance name)))
(defmacro persistent-slot-writer (new-value instance name)
- `(progn
- (with-buffer-streams (key-buf value-buf)
- (buffer-write-int (oid ,instance) key-buf)
- (serialize ,name key-buf)
- (serialize ,new-value value-buf)
- (db-put-buffered (controller-db *store-controller*)
- key-buf value-buf
- :transaction *current-transaction*
- :auto-commit *auto-commit*)
- ,new-value)))
+ `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance)))
+ (persistent-slot-writer-aux (check-con (:dbcn-spc-pst ,instance)) ,new-value ,instance ,name)
+ (with-buffer-streams (key-buf value-buf)
+ (buffer-write-int (oid ,instance) key-buf)
+ (serialize ,name key-buf)
+ (serialize ,new-value value-buf)
+ (db-put-buffered
+ (controller-db (check-con (:dbcn-spc-pst ,instance)))
+ key-buf value-buf
+ :transaction *current-transaction*
+ :auto-commit *auto-commit*)
+ ,new-value)))
#+(or cmu sbcl)
(defun make-persistent-writer (name)
@@ -234,15 +279,22 @@
(type persistent-object instance))
(persistent-slot-writer new-value instance name)))
+;; This this is not a good way to form a key...
+(defun form-slot-key (oid name)
+ (format nil "~A ~A" oid name)
+ )
+
(defmacro persistent-slot-boundp (instance name)
- `(progn
- (with-buffer-streams (key-buf value-buf)
- (buffer-write-int (oid ,instance) key-buf)
- (serialize ,name key-buf)
- (let ((buf (db-get-key-buffered
- (controller-db *store-controller*)
- key-buf value-buf)))
- (if buf T nil)))))
+ `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance)))
+ (persistent-slot-boundp-aux (check-con (:dbcn-spc-pst ,instance)) ,instance ,name)
+ (progn
+ (with-buffer-streams (key-buf value-buf)
+ (buffer-write-int (oid ,instance) key-buf)
+ (serialize ,name key-buf)
+ (let ((buf (db-get-key-buffered
+ (controller-db (check-con (:dbcn-spc-pst ,instance)))
+ key-buf value-buf)))
+ (if buf T nil))))))
#+(or cmu sbcl)
(defun make-persistent-slot-boundp (name)
@@ -265,11 +317,11 @@
(defun persistent-slot-names (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-definition in slot-definitions
- when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition))
- collect (slot-definition-name slot-definition))))
+ when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition))
+ collect (slot-definition-name slot-definition))))
(defun transient-slot-names (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-definition in slot-definitions
- unless (persistent-p slot-definition)
- collect (slot-definition-name slot-definition))))
\ No newline at end of file
+ unless (persistent-p slot-definition)
+ collect (slot-definition-name slot-definition))))
Index: elephant/src/serializer.lisp
diff -u elephant/src/serializer.lisp:1.10 elephant/src/serializer.lisp:1.11
--- elephant/src/serializer.lisp:1.10 Thu Feb 24 02:06:10 2005
+++ elephant/src/serializer.lisp Wed Nov 23 18:51:37 2005
@@ -261,7 +261,7 @@
(push slot-name ret))
finally (return ret)))
-(defun deserialize (buf-str)
+(defun deserialize (buf-str &key sc)
"Deserialize a lisp value from a buffer-stream."
(declare (optimize (speed 3) (safety 0))
(type (or null buffer-stream) buf-str))
@@ -306,7 +306,8 @@
((= tag +ucs4-string+)
(buffer-read-ucs4-string bs (buffer-read-fixnum bs)))
((= tag +persistent+)
- (get-cached-instance *store-controller*
+;; (get-cached-instance *store-controller*
+ (get-cached-instance sc
(buffer-read-fixnum bs)
(%deserialize bs)))
((= tag +single-float+)
@@ -361,13 +362,33 @@
(let* ((id (buffer-read-fixnum bs))
(maybe-o (gethash id *circularity-hash*)))
(if maybe-o maybe-o
- (let ((o (make-instance (%deserialize bs))))
- (setf (gethash id *circularity-hash*) o)
- (loop for i fixnum from 0 below (%deserialize bs)
- do
- (setf (slot-value o (%deserialize bs))
- (%deserialize bs)))
- o))))
+ (let ((typedesig (%deserialize bs)))
+ ;; now, depending on what typedesig is, we might
+ ;; or might not need to specify the store controller here..
+ (let ((o
+ (or (ignore-errors
+ (if (subtypep typedesig 'persistent)
+ (make-instance typedesig :sc sc)
+ ;; if the this type doesn't exist in our object
+ ;; space, we can't reconstitute it, but we don't want
+ ;; to abort completely, we will return a special object...
+ ;; This behavior could be configurable; the user might
+ ;; prefer an abort here, but I prefer surviving...
+ (make-instance typedesig)
+ )
+ )
+ (list 'uninstantiable-object-of-type typedesig)
+ )
+ ))
+ (if (listp o)
+ o
+ (progn
+ (setf (gethash id *circularity-hash*) o)
+ (loop for i fixnum from 0 below (%deserialize bs)
+ do
+ (setf (slot-value o (%deserialize bs))
+ (%deserialize bs)))
+ o)))))))
((= tag +array+)
(let* ((id (buffer-read-fixnum bs))
(maybe-array (gethash id *circularity-hash*)))
@@ -464,3 +485,73 @@
#-(or cmu sbcl allegro)
(byte 32 (* 32 position))
)
+
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (asdf:operate 'asdf:load-op :cl-base64)
+)
+(defun ser-deser-equal (x1 &keys sc)
+ (let* (
+ (x1s (serialize-to-base64-string x1))
+ (x1prime (deserialize-from-base64-string x1s :sc sc)))
+ (assert (equal x1 x1prime))
+ (equal x1 x1prime)))
+
+
+(defun serialize-to-base64-string (x)
+ (with-buffer-streams (out-buf)
+ (cl-base64::usb8-array-to-base64-string
+ (sleepycat::buffer-read-byte-vector
+ (serialize x out-buf))))
+ )
+
+
+(defun deserialize-from-base64-string (x &keys sc)
+ (with-buffer-streams (other)
+ (deserialize
+ (sleepycat::buffer-write-byte-vector
+ other
+ (cl-base64::base64-string-to-usb8-array x))
+ :sc sc
+ )
+ ))
+
+;; (defclass blob ()
+;; ((slot1 :accessor slot1 :initarg :slot1)
+;; (slot2 :accessor slot2 :initarg :slot2)))
+
+;; (defvar keys (loop for i from 1 to 1000
+;; collect (concatenate 'string "key-" (prin1-to-string i))))
+
+;; (defvar objs (loop for i from 1 to 1000
+;; collect (make-instance 'blob
+;; :slot1 i
+;; :slot2 (* i 100))))
+;; (defmethod blob-equal ((a blob) (b blob))
+;; (and (equal (slot1 a) (slot1 b))
+;; (equal (slot2 a) (slot2 b))))
+
+;; (defun test-base64-serializer ()
+;; (let* ((x1 "spud")
+;; (x2 (cons 'a 'b))
+;; (objs (loop for i from 1 to 1000
+;; collect (make-instance 'blob
+;; :slot1 i
+;; :slot2 (* i 100))))
+;; )
+;; (and
+;; (ser-deser-equal x1)
+;; (ser-deser-equal x2)
+;; (reduce
+;; #'(lambda (x y) (and x y))
+;; (mapcar
+;; #'(lambda (x)
+;; (equal x
+;; (with-buffer-streams (other)
+;; (deserialize (serialize x other))
+;; )))
+;; ;; (deserialize-from-base64-string
+;; ;; (serialize-to-base64-string x))))
+;; objs)
+;; :initial-value t)
+;; )))
Index: elephant/src/sleepycat.lisp
diff -u elephant/src/sleepycat.lisp:1.13 elephant/src/sleepycat.lisp:1.14
--- elephant/src/sleepycat.lisp:1.13 Thu Feb 24 02:06:09 2005
+++ elephant/src/sleepycat.lisp Wed Nov 23 18:51:37 2005
@@ -124,44 +124,18 @@
(eval-when (:compile-toplevel)
(proclaim '(optimize (ext:inhibit-warnings 3))))
-(eval-when (:compile-toplevel :load-toplevel)
- ;; UFFI
- ;;(asdf:operate 'asdf:load-op :uffi)
- ;; DSO loading - Edit these for your system!
+(eval-when (:compile-toplevel :load-toplevel)
- ;; Under linux you may need to load some kind of pthread
- ;; library. I can't figure out which is the right one.
- ;; This one worked for me. There are known issues with
- ;; Red Hat and Berkeley DB, search google.
- #+linux
- (unless
- (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread")
- (error "Couldn't load libpthread!"))
-
- (unless
- (uffi:load-foreign-library
- ;; Sleepycat: this works on linux
- #+linux
- "/db/ben/lisp/db43/lib/libdb.so"
- ;; this works on FreeBSD
- #+(and (or bsd freebsd) (not darwin))
- "/usr/local/lib/db43/libdb.so"
- #+darwin
- "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib"
- :module "sleepycat")
- (error "Couldn't load libdb (Sleepycat)!"))
-
- ;; Libsleepycat.so: edit this
- (unless
- (uffi:load-foreign-library
- (if (find-package 'asdf)
- (merge-pathnames
- #p"libsleepycat.so"
- (asdf:component-pathname (asdf:find-system 'elephant)))
- "/usr/local/share/common-lisp/elephant-0.2/libsleepycat.so")
- :module "libsleepycat")
- (error "Couldn't load libsleepycat!"))
+ (unless
+ (uffi:load-foreign-library
+ (if (find-package 'asdf)
+ (merge-pathnames
+ #p"libmemutil.so"
+ (asdf:component-pathname (asdf:find-system 'elephant)))
+ (format nil "~A/~A" *elephant-lib-path* "libmemutil.so"))
+ :module "libmemutil")
+ (error "Couldn't load libmemutil.so!"))
;; fini on user editable part
@@ -786,7 +760,32 @@
(type buffer-stream bs))
(let ((position (buffer-stream-position bs)))
(incf (buffer-stream-position bs))
- (deref-array (buffer-stream-buffer bs) '(:array :char) position)))
+ (deref-array (buffer-stream-buffer bs) '(:array :unsigned-byte) position)))
+
+(defun buffer-read-byte-vector (bs)
+ "Read the whole buffer into byte vector."
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let* ((position (buffer-stream-position bs))
+ (size (buffer-stream-size bs))
+ (vlen (- size position)))
+ (if (>= vlen 0)
+ (let ((v (make-array vlen :element-type '(unsigned-byte 8))))
+ (dotimes (i vlen v)
+ (setf (aref v i) (buffer-read-byte bs))))
+ nil)))
+
+(defun buffer-write-byte-vector (bs bv)
+ "Read the whole buffer into byte vector."
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let* ((position (buffer-stream-position bs))
+ (size (buffer-stream-size bs))
+ (vlen (length bv))
+ (writable (max vlen (- size position))))
+ (dotimes (i writable bs)
+ (buffer-write-byte (aref bv i) bs))))
+
(defun buffer-read-fixnum (bs)
"Read a 32-bit signed integer, which is assumed to be a fixnum."
@@ -828,6 +827,17 @@
(setf (buffer-stream-position bs) (+ position 8))
(read-double (buffer-stream-buffer bs) position)))
+;; A non-back-compatible change was made in SBCL 8 moving to SBCL 9,
+;; in that the function copy-from-system-area disappeared.
+;; This code is an attempt to allow compilation under bothe SBCL 8 and SBCL 9.
+;; Thanks to Juho Snellman for this idiom.
+(eval-when (:compile-toplevel)
+ (defun new-style-copy-p ()
+ (if (find-symbol "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")
+ '(:and)
+ '(:or)))
+ )
+
(defun buffer-read-ucs1-string (bs byte-length)
"Read a UCS1 string."
(declare (optimize (speed 3) (safety 0))
@@ -841,6 +851,14 @@
:length byte-length :null-terminated-p nil)
#+(and sbcl sb-unicode)
(let ((res (make-string byte-length :element-type 'base-char)))
+#+#.(sleepycat::new-style-copy-p)
+ (sb-kernel:copy-ub8-from-system-area
+ (sb-alien:alien-sap (buffer-stream-buffer bs))
+ (* position sb-vm:n-byte-bits)
+ res
+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+ (* byte-length sb-vm:n-byte-bits))
+#-#.(sleepycat::new-style-copy-p)
(sb-kernel:copy-from-system-area
(sb-alien:alien-sap (buffer-stream-buffer bs))
(* position sb-vm:n-byte-bits)
@@ -877,6 +895,14 @@
(let ((position (buffer-stream-position bs)))
(setf (buffer-stream-position bs) (+ position byte-length))
(let ((res (make-string (/ byte-length 4) :element-type 'character)))
+#+#.(sleepycat::new-style-copy-p)
+ (sb-kernel:copy-ub8-from-system-area
+ (sb-alien:alien-sap (buffer-stream-buffer bs))
+ (* position sb-vm:n-byte-bits)
+ res
+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+ (* byte-length sb-vm:n-byte-bits))
+#-#.(sleepycat::new-style-copy-p)
(sb-kernel:copy-from-system-area
(sb-alien:alien-sap (buffer-stream-buffer bs))
(* position sb-vm:n-byte-bits)
Index: elephant/src/utils.lisp
diff -u elephant/src/utils.lisp:1.8 elephant/src/utils.lisp:1.9
--- elephant/src/utils.lisp:1.8 Thu Feb 24 02:06:08 2005
+++ elephant/src/utils.lisp Wed Nov 23 18:51:38 2005
@@ -99,36 +99,65 @@
#+(or cmu sbcl allegro) *resourced-byte-spec*))
(funcall thunk)))
+;; get rid of spot idx and adjust the arrray
+(defun remove-indexed-element-and-adjust (idx array)
+ (let ((last (- (length array) 1)))
+ (do ((i idx (1+ i)))
+ ((= i last) nil)
+ (progn
+ (setf (aref array i) (aref array (+ 1 i)))))
+ (adjust-array array last)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macros
-
;; Good defaults for elephant
-(defmacro with-transaction ((&key transaction
- (environment '(controller-environment
- *store-controller*))
- (parent '*current-transaction*)
- degree-2 dirty-read txn-nosync
- txn-nowait txn-sync
- (retries 100))
- &body body)
+(defmacro with-transaction (
+ (&key transaction
+ (store-controller '*store-controller*)
+ environment
+ (parent '*current-transaction*)
+ degree-2 dirty-read txn-nosync
+ txn-nowait txn-sync
+ (retries 100))
+ &body body
+)
"Execute a body with a transaction in place. On success,
the transaction is committed. Otherwise, the transaction is
aborted. If the body deadlocks, the body is re-executed in
a new transaction, retrying a fixed number of iterations.
*auto-commit* is false for the body of the transaction."
- `(sleepycat:with-transaction (:transaction ,transaction
- :environment ,environment
- :parent ,parent
- :degree-2 ,degree-2
- :dirty-read ,dirty-read
- :txn-nosync ,txn-nosync
- :txn-nowait ,txn-nowait
- :txn-sync ,txn-sync
- :retries ,retries)
- (let ((*auto-commit* nil))
- , at body)))
+ `(if (not (typep ,store-controller 'elephant::bdb-store-controller))
+ (elephant::with-transaction-sql (:store-controller-sql ,store-controller)
+ , at body)
+;; (if (clsql::in-transaction-p
+;; :database
+;; (controller-db ,store-controller))
+;; (progn
+;; , at body)
+;; (prog2
+;; (clsql::set-autocommit nil)
+;; (clsql::with-transaction
+;; (:database
+;; (controller-db ,store-controller))
+;; , at body)
+;; (clsql::set-autocommit t)))
+ (let ((env (if ,environment ,environment
+ (controller-environment ,store-controller))))
+ (sleepycat:with-transaction (:transaction ,transaction
+ :environment env
+ :parent ,parent
+ :degree-2 ,degree-2
+ :dirty-read ,dirty-read
+ :txn-nosync ,txn-nosync
+ :txn-nowait ,txn-nowait
+ :txn-sync ,txn-sync
+ :retries ,retries)
+
+ (let ((*auto-commit* nil))
+ , at body)))
+ ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
More information about the Elephant-cvs
mailing list