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@common-lisp.net> +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; <ablumberg@common-lisp.net> <blee@common-lisp.net> +;;; +;;; 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@common-lisp.net> +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; <ablumberg@common-lisp.net> <blee@common-lisp.net> +;;; +;;; 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@common-lisp.net> +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; <ablumberg@common-lisp.net> <blee@common-lisp.net> +;;; +;;; 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@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@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 + ,@body) + (prog2 + (clsql::set-autocommit nil) + (clsql::with-transaction + (:database + (controller-db ,store-controller-sql)) + ,@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 ,@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 ,@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 @@ ,@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 ,@body) - (close-controller *store-controller*)))) + `(let ((*store-controller* + (get-controller ,spec))) + (declare (special *store-controller*)) +;; (open-controller *store-controller*) + (unwind-protect + (progn ,@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)) - ,@body))) + `(if (not (typep ,store-controller 'elephant::bdb-store-controller)) + (elephant::with-transaction-sql (:store-controller-sql ,store-controller) + ,@body) +;; (if (clsql::in-transaction-p +;; :database +;; (controller-db ,store-controller)) +;; (progn +;; ,@body) +;; (prog2 +;; (clsql::set-autocommit nil) +;; (clsql::with-transaction +;; (:database +;; (controller-db ,store-controller)) +;; ,@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)) + ,@body))) + )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;