From blee at common-lisp.net Thu Sep 2 07:01:38 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:01:38 +0200 Subject: [elephant-cvs] CVS update: elephant/INSTALL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv16190 Modified Files: INSTALL Log Message: 0.1 Date: Thu Sep 2 09:01:37 2004 Author: blee Index: elephant/INSTALL diff -u elephant/INSTALL:1.5 elephant/INSTALL:1.6 --- elephant/INSTALL:1.5 Tue Aug 31 01:46:12 2004 +++ elephant/INSTALL Thu Sep 2 09:01:37 2004 @@ -29,7 +29,7 @@ 0) Unpack Elephant. I put mine in the directory -/usr/local/share/common-lisp/elephant/ +/usr/local/share/common-lisp/elephant-0.1/ 1) Install UFFI 1.4.24. Replace From blee at common-lisp.net Thu Sep 2 07:03:53 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:03:53 +0200 Subject: [elephant-cvs] CVS update: elephant/Makefile Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv16450 Modified Files: Makefile Log Message: conditionalize darwin Date: Thu Sep 2 09:03:53 2004 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.1 elephant/Makefile:1.2 --- elephant/Makefile:1.1 Sun Aug 29 22:34:10 2004 +++ elephant/Makefile Thu Sep 2 09:03:51 2004 @@ -1,24 +1,30 @@ # -# Makefile for compiling libsleepycat.c +# GNU Makefile for compiling libsleepycat.c (BSDers use gmake) # # Contributed by Rafal Strzalinski # SHELL=/bin/sh +UNAME:=$(shell uname -s) # *BSD users will probably want -# DBLIBDIR=/usr/local/lib/db42 -# DBINCDIR=/usr/local/include/db42 +DBLIBDIR=/usr/local/lib/db42 +DBINCDIR=/usr/local/include/db42 -DB42DIR=/usr/local/BerkeleyDB.4.2 - -DBLIBDIR=$(DB42DIR)/lib/ -DBINCDIR=$(DB42DIR)/include/ - -INSTALLDIR=/usr/local/share/common-lisp/elephant/ +#DB42DIR=/usr/local/BerkeleyDB.4.2 +#DBLIBDIR=$(DB42DIR)/lib/ +#DBINCDIR=$(DB42DIR)/include/ + +INSTALLDIR=/usr/local/share/common-lisp/elephant-0.1/ + +ifeq (Darwin,$(UNAME)) + SHARED=-bundle +else + SHARED=-shared +endif libsleepycat.so: src/libsleepycat.c - gcc -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -shared -O3 -o $@ $< -ldb + gcc $(SHARED) -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb install: libsleepycat.so install $< $(INSTALLDIR) From blee at common-lisp.net Thu Sep 2 07:05:36 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:05:36 +0200 Subject: [elephant-cvs] CVS update: elephant/TODO Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv16480 Modified Files: TODO Log Message: notes from rtoy on bignums Date: Thu Sep 2 09:05:36 2004 Author: blee Index: elephant/TODO diff -u elephant/TODO:1.1 elephant/TODO:1.2 --- elephant/TODO:1.1 Mon Aug 30 23:41:34 2004 +++ elephant/TODO Thu Sep 2 09:05:36 2004 @@ -14,7 +14,9 @@ Lispworks stuff (fli:replace-foreign-array...) -bignum fix +bignum fix: CMUCL / SBCL use %bignum-ref. OpenMCL: check +that ldb is non-consing (i think it is), look at +%ldb-fixnum-from-bignum) serialize lambdas, closures, packages..... From blee at common-lisp.net Thu Sep 2 07:09:58 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:09:58 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv16566/src Modified Files: classes.lisp Log Message: openmcl, fixed shared-initialize, slot-mkunbound Date: Thu Sep 2 09:09:57 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.6 elephant/src/classes.lisp:1.7 --- elephant/src/classes.lisp:1.6 Mon Aug 30 23:14:25 2004 +++ elephant/src/classes.lisp Thu Sep 2 09:09:57 2004 @@ -67,26 +67,37 @@ (call-next-method)))) (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) + "This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al aren't used." (let* ((class (class-of instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) (member item persistent-slot-names :test #'eq))) (let ((transient-slot-inits - (if (eq slot-names t) + (if (eq slot-names t) ; t means all slots (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) - (loop for slot-def in (class-slots class) - when (member (slot-definition-name slot-def) - persistent-slot-inits) - 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))))) + ;; 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)))) + (loop for slot-def in (class-slots class) + unless (initialize-from-initarg slot-def) + when (member (slot-definition-name slot-def) persistent-slot-names :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 slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) @@ -107,11 +118,11 @@ (defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (declare (ignore class)) (buffer-write-int (oid instance) *key-buf*) - (let* ((key-length (serialize (slot-definition-name slot-def) *key-buf*)) - (buf (db-delete-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length - :transaction *current-transaction* - :auto-commit *auto-commit*))))) + (let ((key-length (serialize (slot-definition-name slot-def) *key-buf*))) + (db-delete-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length + :transaction *current-transaction* + :auto-commit *auto-commit*))) From blee at common-lisp.net Thu Sep 2 07:10:35 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:10:35 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv16598/src Modified Files: elephant.lisp Log Message: openmcl Date: Thu Sep 2 09:10:34 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.7 elephant/src/elephant.lisp:1.8 --- elephant/src/elephant.lisp:1.7 Mon Aug 30 23:14:49 2004 +++ elephant/src/elephant.lisp Thu Sep 2 09:10:34 2004 @@ -43,7 +43,6 @@ (defpackage elephant (:nicknames ele :ele) (:use common-lisp sleepycat) - (:shadow #:with-transaction) (:export #:*store-controller* #:*current-transaction* #:*auto-commit* #:open-store #:close-store #:store-controller #:open-controller #:close-controller @@ -75,6 +74,7 @@ slot-value-using-class slot-boundp-using-class slot-definition-allocation + slot-definition-initargs compute-slots initialize-internal-slot-functions @@ -105,6 +105,7 @@ slot-value-using-class slot-boundp-using-class slot-definition-allocation + slot-definition-initargs compute-slots) #+sbcl (:import-from :sb-pcl @@ -136,17 +137,55 @@ slot-value-using-class slot-boundp-using-class slot-definition-allocation + slot-definition-initargs compute-slots) #+allegro (:import-from :excl compute-effective-slot-definition-initargs) - #+openmcl - (:import-from :openmcl-mop + #+openmcl + (:import-from :ccl + validate-superclass + standard-slot-definition + standard-direct-slot-definition + standard-effective-slot-definition + direct-slot-definition-class + effective-slot-definition-class slot-definition-name - compute-slots) + slot-definition-initfunction + compute-effective-slot-definition + class-slots + slot-value-using-class + slot-boundp-using-class + slot-definition-allocation + slot-definition-initargs + compute-slots + ;; This stuff we need until we resolve the :transient + ;; slot specifier stuff + make-effective-slot-definition + slots-class + %slot-definition-initfunction + %slot-definition-documentation + %slot-definition-initargs + %slot-definition-initform + %slot-definition-allocation + %slot-definition-class + %slot-definition-type) #+lispworks (:import-from :clos + validate-superclass + standard-slot-definition + standard-direct-slot-definition + standard-effective-slot-definition + direct-slot-definition-class + effective-slot-definition-class slot-definition-name + slot-definition-initfunction + compute-effective-slot-definition + class-slots + slot-value-using-class + slot-boundp-using-class + slot-definition-allocation + slot-definition-initargs compute-slots) ) From blee at common-lisp.net Thu Sep 2 07:15:51 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:15:51 +0200 Subject: [elephant-cvs] CVS update: elephant/src/metaclasses.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv17181/src Modified Files: metaclasses.lisp Log Message: openmcl Date: Thu Sep 2 09:15:49 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.3 elephant/src/metaclasses.lisp:1.4 --- elephant/src/metaclasses.lisp:1.3 Mon Aug 30 23:15:12 2004 +++ elephant/src/metaclasses.lisp Thu Sep 2 09:15:48 2004 @@ -83,6 +83,7 @@ (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient))) + (when (consp transient-p) (setq transient-p (car transient-p))) (cond ((and (eq allocation-key :class) transient-p) (find-class 'transient-direct-slot-definition)) ((and (eq allocation-key :class) (not transient-p)) @@ -111,6 +112,7 @@ (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((transient-p (getf initargs :transient))) + (when (consp transient-p) (setq transient-p (car transient-p))) (cond (transient-p (find-class 'transient-effective-slot-definition)) (t @@ -138,6 +140,43 @@ (let ((slot-definition (call-next-method))) (ensure-storage-exists class slot-definition slot-name) slot-definition)) + +#+openmcl +(defmethod compute-effective-slot-definition ((class persistent-metaclass) slot-name direct-slot-definitions) + (declare (ignore slot-name)) + (apply #'make-effective-slot-definition class + (compute-effective-slot-definition-initargs + class direct-slot-definitions))) + +#+openmcl +(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)))) + (initer (dolist (s direct-slots) + (when (%slot-definition-initfunction s) + (return s)))) + (documentor (dolist (s direct-slots) + (when (%slot-definition-documentation s) + (return s)))) + (first (car direct-slots)) + (initargs (let* ((initargs nil)) + (dolist (dslot direct-slots initargs) + (dolist (dslot-arg (%slot-definition-initargs dslot)) + (pushnew dslot-arg initargs :test #'eq)))))) + (list + :name name + :allocation (%slot-definition-allocation first) + :documentation (when documentor (nth-value + 1 + (%slot-definition-documentation + documentor))) + :class (%slot-definition-class first) + :initargs initargs + :initfunction (if initer (%slot-definition-initfunction initer)) + :initform (if initer (%slot-definition-initform initer)) + :type (or (%slot-definition-type first) t)))) (defun ensure-transient-chain (slot-definitions initargs) (declare (ignore initargs)) From blee at common-lisp.net Thu Sep 2 07:18:09 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:18:09 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv18343/src Modified Files: sleepycat.lisp Log Message: openmcl, errors on library load failure Date: Thu Sep 2 09:18:08 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.7 elephant/src/sleepycat.lisp:1.8 --- elephant/src/sleepycat.lisp:1.7 Mon Aug 30 23:36:54 2004 +++ elephant/src/sleepycat.lisp Thu Sep 2 09:18:08 2004 @@ -85,21 +85,29 @@ ;; This one worked for me. There are known issues with ;; Red Hat and Berkeley DB, search google. #+linux - (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") - - ;; Sleepycat: this works on linux - #-bsd - (uffi:load-foreign-library "/usr/local/BerkeleyDB.4.2/lib/libdb.so" - :module "sleepycat") - ;; this works on FreeBSD - #+bsd - (uffi:load-foreign-library "/usr/local/lib/db42/libdb.so" - :module "sleepycat") + (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 + "/usr/local/BerkeleyDB.4.2/lib/libdb.so" + ;; this works on FreeBSD + #+(or bsd freebsd) + "/usr/local/lib/db42/libdb.so" + #+darwin + "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" + :module "sleepycat") + (error "Couldn't load libdb (Sleepycat)!")) ;; Libsleepycat.so: edit this - (uffi:load-foreign-library - "/usr/local/share/common-lisp/elephant/libsleepycat.so" - :module "libsleepycat") + (unless + (uffi:load-foreign-library + "/usr/local/share/common-lisp/elephant-0.1/libsleepycat.so" + :module "libsleepycat") + (error "Couldn't load libsleepycat!")) ;; fini on user editable part @@ -107,7 +115,7 @@ (def-type pointer-void :pointer-void) (def-foreign-type array-or-pointer-char #+allegro (:array :char) - #+(or cmu sbcl scl) (* :char)) + #+(or cmu sbcl scl openmcl) (* :char)) (def-type array-or-pointer-char array-or-pointer-char) (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN)) ) @@ -171,8 +179,8 @@ (defconstant DB_LOCK_NOTGRANTED -30994) (defconstant DB_NOTFOUND -30990) -(defconstant +NULL-VOID+ (make-null-pointer :void)) -(defconstant +NULL-CHAR+ (make-null-pointer :char)) +(defvar +NULL-VOID+ (make-null-pointer :void)) +(defvar +NULL-CHAR+ (make-null-pointer :char)) ;; Buffer management / pointer arithmetic @@ -273,7 +281,7 @@ (dynamic-extent src dest length)) (multiple-value-bind (ivector disp) (ccl::array-data-and-offset src) - (ccl::%copy-ivector-to-ptr src (+ disp src-offset) + (ccl::%copy-ivector-to-ptr ivector (+ disp src-offset) dest dest-offset length))) ;; Lisp version, for kicks. this assumes 8-bit chars! @@ -858,7 +866,7 @@ (type boolean txn-nosync txn-sync))) (defmacro with-transaction ((&key transaction environment - (parent '*current-transaction*) + (parent *current-transaction*) (retries 100) dirty-read txn-nosync txn-nowait txn-sync) @@ -934,12 +942,18 @@ (gen :unsigned-int) (mode DB-LOCKMODE)) +#+openmcl +(ccl:def-foreign-type DB-LOCK (:struct DB-LOCK)) + (def-struct DB-LOCKREQ (op DB-LOCKOP) (mode DB-LOCKMODE) (timeout :unsigned-int) (obj (:array :char)) (lock (* DB-LOCK))) + +#+openmcl +(ccl:def-foreign-type DB-LOCKREQ (:struct DB-LOCKREQ)) (def-function ("db_txn_id" %db-transaction-id) ((transaction :pointer-void)) From blee at common-lisp.net Thu Sep 2 07:21:46 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:21:46 +0200 Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv20809/src Modified Files: utils.lisp Log Message: reorder, typos Date: Thu Sep 2 09:21:45 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.2 elephant/src/utils.lisp:1.3 --- elephant/src/utils.lisp:1.2 Sun Aug 29 22:41:55 2004 +++ elephant/src/utils.lisp Thu Sep 2 09:21:45 2004 @@ -73,14 +73,32 @@ ;;; ;;; Thread-local specials +(defparameter *store-controller* nil + "The store controller which persistent objects talk to.") + +;; Specials which control persistent objects +(defvar *auto-commit* T) + +(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*)) + +;; Buffers for going in and out of the DB +(defvar *out-buf* (make-buffer-stream)) +(defvar *key-buf* (make-buffer-stream)) +(defvar *in-buf* (make-buffer-stream)) + +;; Stuff the serializer uses +(defvar *lisp-obj-id* 0) +(defvar *circularity-hash* (make-hash-table :test 'eq)) +#+(or cmu scl sbcl allegro) +(defvar *resourced-byte-spec* (byte 32 0)) + ;; TODO: make this for real! (defun run-elephant-thread (thunk) - (let ((*current-transaction* +NULL-vOID+) + (let ((*current-transaction* +NULL-VOID+) (*errno-buffer* (allocate-foreign-object :int 1)) (*get-buffer* (allocate-foreign-object :char 1)) (*get-buffer-length* 0) - (*store-controller* nil) - ;(*auto-commit* T) which is correct? + (*store-controller* *store-controller*) (*auto-commit* *auto-commit*) (*out-buf* (make-buffer-stream)) (*key-buf* (make-buffer-stream)) @@ -97,26 +115,6 @@ (funcall thunk))) -(defparameter *store-controller* nil - "The store controller which persistent objects talk to.") - -;; Specials which control persistent objects -(defvar *auto-commit* T) - -(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*)) - -;; Buffers for going in and out of the DB -(defvar *out-buf* (make-buffer-stream)) -(defvar *key-buf* (make-buffer-stream)) -(defvar *in-buf* (make-buffer-stream)) - -;; Stuff the serializer uses -(defvar *lisp-obj-id* 0) -(defvar *circularity-hash* (make-hash-table :test 'eq)) -#+(or cmu scl sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Macros @@ -125,7 +123,7 @@ (defmacro with-transaction ((&key transaction (environment (controller-environment *store-controller*)) - (parent '*current-transaction*) + (parent *current-transaction*) dirty-read txn-nosync txn-nowait txn-sync) &body body) From blee at common-lisp.net Thu Sep 2 07:30:15 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:30:15 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/mop-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv22882/tests Modified Files: mop-tests.lisp Log Message: initarg / form tests Date: Thu Sep 2 09:30:13 2004 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.1 elephant/tests/mop-tests.lisp:1.2 --- elephant/tests/mop-tests.lisp:1.1 Mon Aug 30 23:39:09 2004 +++ elephant/tests/mop-tests.lisp Thu Sep 2 09:30:12 2004 @@ -81,4 +81,13 @@ (defclass p-initform-test () ((slot1 :initform 10)) - (:metaclass persistent-metaclass)) \ No newline at end of file + (:metaclass persistent-metaclass)) + +(defclass p-initform-test-2 () + ((slot1 :initarg :slot1 :initform 10)) + (:metaclass persistent-metaclass)) + +(setq pf (make-instance 'p-initform-test-2)) +(slot-value pf 'slot1) +(setq pf (make-instance 'p-initform-test-2 :slot1 20)) +(slot-value pf 'slot1) From blee at common-lisp.net Thu Sep 2 07:32:17 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 09:32:17 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testserializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv23523/tests Modified Files: testserializer.lisp Log Message: typo Date: Thu Sep 2 09:32:16 2004 Author: blee Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.1 elephant/tests/testserializer.lisp:1.2 --- elephant/tests/testserializer.lisp:1.1 Mon Aug 30 23:39:59 2004 +++ elephant/tests/testserializer.lisp Thu Sep 2 09:32:16 2004 @@ -16,7 +16,7 @@ (eq nil (cdr g)) (setq h (make-hash-table :test 'eql)) -(setf (gethash 10000000000 h) f) +(prog1 t (setf (gethash 10000000000 h) f)) (setq h2 (test h)) (= 1 (hash-table-count h2)) (prog1 t (setq g (gethash 10000000000 h2))) From blee at common-lisp.net Thu Sep 2 14:39:12 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 16:39:12 +0200 Subject: [elephant-cvs] CVS update: elephant/TUTORIAL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv30393 Modified Files: TUTORIAL Log Message: comments on initforms and transactions Date: Thu Sep 2 16:39:12 2004 Author: blee Index: elephant/TUTORIAL diff -u elephant/TUTORIAL:1.4 elephant/TUTORIAL:1.5 --- elephant/TUTORIAL:1.4 Sun Aug 29 22:35:37 2004 +++ elephant/TUTORIAL Thu Sep 2 16:39:12 2004 @@ -250,6 +250,11 @@ you're concerned, cache values. (In the future we will provide automatic value caching.) +Finally, if you for some reason make an instance with a +specified OID which already exists in the database, initargs +take precedence over values in the database, which take +precedences over initforms. + ------------ Transactions ------------ @@ -388,3 +393,21 @@ The serializer is definitely fast on fixnums, strings, and persistent things. It is fairly fast but consing with floats and doubles. YMMV with other values. + +Using *auto-commit* and not "with-transactions" is a great +way to have a huge number of transactions. You'll find that + +(dotimes (i 1000) (add-to-root "key" "value")) + +is way slower than + +(let ((*auto-commit* nil)) + (with-transaction () + (dotimes (i 1000) (add-to-root "key" "value")))) + +since there's only 1 transaction in the latter. + +Use the persistent classes and collections; if you're using +transactions correctly they should be much faster. + +If you don't need transactions you can turn them off. From blee at common-lisp.net Thu Sep 2 14:41:26 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 16:41:26 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30423/src Modified Files: classes.lisp Log Message: typo Date: Thu Sep 2 16:41:25 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.7 elephant/src/classes.lisp:1.8 --- elephant/src/classes.lisp:1.7 Thu Sep 2 09:09:57 2004 +++ elephant/src/classes.lisp Thu Sep 2 16:41:25 2004 @@ -90,7 +90,7 @@ (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-names :test #'eq) + 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))) From blee at common-lisp.net Thu Sep 2 14:42:39 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 16:42:39 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30449/src Modified Files: controller.lisp Log Message: next-oid fix: bug in counters, they weren't using the parent transactions and so were dead locking inside of with-transactions Date: Thu Sep 2 16:42:38 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.6 elephant/src/controller.lisp:1.7 --- elephant/src/controller.lisp:1.6 Sun Aug 29 22:37:58 2004 +++ elephant/src/controller.lisp Thu Sep 2 16:42:38 2004 @@ -113,6 +113,7 @@ (defmethod next-oid ((sc store-controller)) (sleepycat::next-counter (controller-environment sc) (controller-db sc) + *current-transaction* %oid-entry %oid-entry-length %oid-lock %oid-lock-length)) From blee at common-lisp.net Thu Sep 2 14:45:55 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 16:45:55 +0200 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv31060/src Modified Files: libsleepycat.c Log Message: next-oid fix: bug in counters, they weren't using the parent transactions and so were dead locking inside of with-transactions Date: Thu Sep 2 16:45:53 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.6 elephant/src/libsleepycat.c:1.7 --- elephant/src/libsleepycat.c:1.6 Sun Aug 29 22:39:29 2004 +++ elephant/src/libsleepycat.c Thu Sep 2 16:45:53 2004 @@ -416,7 +416,8 @@ /* Poor man's counters */ -int next_counter(DB_ENV *env, DB *db, char *key, u_int32_t key_length, +int next_counter(DB_ENV *env, DB *db, DB_TXN *parent, + char *key, u_int32_t key_length, char *lockid, u_int32_t lockid_length) { DB_LOCK lock; DBT DBTKey, DBTData; @@ -439,7 +440,7 @@ lockheld = 0; /* Begin the transaction. */ - if ((ret = env->txn_begin(env, NULL, &tid, 0)) != 0) { + if ((ret = env->txn_begin(env, parent, &tid, 0)) != 0) { env->err(env, ret, "DB_ENV->txn_begin"); return (-1); } From blee at common-lisp.net Thu Sep 2 14:47:12 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 16:47:12 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv31310/src Modified Files: sleepycat.lisp Log Message: next-oid fix: bug in counters, they weren't using the parent transactions and so were dead locking inside of with-transactions nested transactions are borking -- kword default to with-transactions should be '*current-transaction*, not *current-transaction* -- i want to capture the dynamic, not lexical environment Date: Thu Sep 2 16:47:11 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.8 elephant/src/sleepycat.lisp:1.9 --- elephant/src/sleepycat.lisp:1.8 Thu Sep 2 09:18:08 2004 +++ elephant/src/sleepycat.lisp Thu Sep 2 16:47:09 2004 @@ -866,7 +866,7 @@ (type boolean txn-nosync txn-sync))) (defmacro with-transaction ((&key transaction environment - (parent *current-transaction*) + (parent '*current-transaction*) (retries 100) dirty-read txn-nosync txn-nowait txn-sync) @@ -1078,14 +1078,15 @@ (def-function ("next_counter" %next-counter) ((env :pointer-void) (db :pointer-void) + (parent :pointer-void) (key array-or-pointer-char) (key-length :unsigned-int) (lockid array-or-pointer-char) (lockid-length :unsigned-int)) :returning :int) -(defun next-counter (env db key key-length lockid lockid-length) - (let ((ret (%next-counter env db key key-length lockid lockid-length))) +(defun next-counter (env db parent key key-length lockid lockid-length) + (let ((ret (%next-counter env db parent key key-length lockid lockid-length))) (if (< ret 0) (error 'db-error :errno ret) ret))) From blee at common-lisp.net Thu Sep 2 14:47:32 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 16:47:32 +0200 Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv31364/src Modified Files: utils.lisp Log Message: nested transactions are borking -- kword default to with-transactions should be '*current-transaction*, not *current-transaction* -- i want to capture the dynamic, not lexical environment Date: Thu Sep 2 16:47:31 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.3 elephant/src/utils.lisp:1.4 --- elephant/src/utils.lisp:1.3 Thu Sep 2 09:21:45 2004 +++ elephant/src/utils.lisp Thu Sep 2 16:47:31 2004 @@ -123,9 +123,10 @@ (defmacro with-transaction ((&key transaction (environment (controller-environment *store-controller*)) - (parent *current-transaction*) + (parent '*current-transaction*) dirty-read txn-nosync - txn-nowait txn-sync) + txn-nowait txn-sync + (retries 100)) &body body) `(sleepycat:with-transaction (:transaction ,transaction :environment ,environment @@ -133,7 +134,8 @@ :dirty-read ,dirty-read :txn-nosync ,txn-nosync :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) + :txn-sync ,txn-sync + :retries ,100) , at body)) From blee at common-lisp.net Thu Sep 2 14:47:54 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 16:47:54 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv31423/src Modified Files: elephant.lisp Log Message: turns out i need to shadow with-transaction after all! Date: Thu Sep 2 16:47:53 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.8 elephant/src/elephant.lisp:1.9 --- elephant/src/elephant.lisp:1.8 Thu Sep 2 09:10:34 2004 +++ elephant/src/elephant.lisp Thu Sep 2 16:47:53 2004 @@ -43,6 +43,7 @@ (defpackage elephant (:nicknames ele :ele) (:use common-lisp sleepycat) + (:shadow #:with-transaction) (:export #:*store-controller* #:*current-transaction* #:*auto-commit* #:open-store #:close-store #:store-controller #:open-controller #:close-controller From blee at common-lisp.net Thu Sep 2 15:12:02 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 17:12:02 +0200 Subject: [elephant-cvs] CVS update: elephant/TUTORIAL elephant/TODO elephant/NEWS elephant/INSTALL elephant/ChangeLog Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv5302 Modified Files: TUTORIAL TODO NEWS INSTALL ChangeLog Log Message: update of docs (for openmcl, revisions) Date: Thu Sep 2 17:11:59 2004 Author: blee Index: elephant/TUTORIAL diff -u elephant/TUTORIAL:1.5 elephant/TUTORIAL:1.6 --- elephant/TUTORIAL:1.5 Thu Sep 2 16:39:12 2004 +++ elephant/TUTORIAL Thu Sep 2 17:11:58 2004 @@ -138,10 +138,7 @@ (get-from-root "my other key")) => NIL -As a consequence, btrees have a sort of mishmash eql / -equalp hashing. - -2) Changing substructures are not automatically saved: +2) Changing substructures is not automatically saved: * (setf (car foo) T) => T @@ -156,7 +153,7 @@ maintain, deserialization must re-cons the entire object every time. Plus, one of the reasons to use a database is if your objects can't fit into main memory all at - once! + once, so lazy allocation is desirable. 4) Merge-conflicts in heavily multi-process/threaded situations. More on this later. @@ -244,11 +241,15 @@ persistent, it cannot later be changed to a transient slot. Note that the database is read every time you access a slot. -In particular, if your slot value is not an immediate value, -this will cons the value. Gets are not an expensive -operation (I can do a million reads in 30 seconds), but if -you're concerned, cache values. (In the future we will -provide automatic value caching.) +This is a feature, not a bug, especially in concurrent +situations: you want the most recent commits, right? +(Sleepycat will give isolation inside of transactions, +though.) In particular, if your slot value is not an +immediate value, reading will cons the value. Gets are not +an expensive operation (I can do a million reads in 30 +seconds), but if you're concerned, cache values. In the +future we will provide automatic value caching -- "single +user mode." Finally, if you for some reason make an instance with a specified OID which already exists in the database, initargs @@ -392,7 +393,8 @@ The serializer is definitely fast on fixnums, strings, and persistent things. It is fairly fast but consing with -floats and doubles. YMMV with other values. +floats and doubles. YMMV with other values, though I've +tried to make them fast. Using *auto-commit* and not "with-transactions" is a great way to have a huge number of transactions. You'll find that @@ -411,3 +413,6 @@ transactions correctly they should be much faster. If you don't need transactions you can turn them off. +Opening the DB in less concurrent / transctional modes will +be supported very soon (it's just an argument change, I +think.) Index: elephant/TODO diff -u elephant/TODO:1.2 elephant/TODO:1.3 --- elephant/TODO:1.2 Thu Sep 2 09:05:36 2004 +++ elephant/TODO Thu Sep 2 17:11:58 2004 @@ -22,6 +22,4 @@ lispy pointer arithmetic -OpenMCL! - performance hacks: class / slot to ID Index: elephant/NEWS diff -u elephant/NEWS:1.3 elephant/NEWS:1.4 --- elephant/NEWS:1.3 Tue Aug 31 01:53:32 2004 +++ elephant/NEWS Thu Sep 2 17:11:58 2004 @@ -1,4 +1,12 @@ +September 2, 2004 - + +The bad news: there was a bug in 0.1 which made OID +generation inside of manual transactions deadlock. + +The good news: this is fixed, and I've added OpenMCL +support. So I'm releasing 0.1-p1. + August 30, 2004 - Elephant 0.1 was released August 30th, 2004. This is an Index: elephant/INSTALL diff -u elephant/INSTALL:1.6 elephant/INSTALL:1.7 --- elephant/INSTALL:1.6 Thu Sep 2 09:01:37 2004 +++ elephant/INSTALL Thu Sep 2 17:11:58 2004 @@ -3,9 +3,9 @@ Requirements ------------ -CMUCL 19a, SBCL 0.8.13, or Allegro CL 6.2. I've tested -under FreeBSD and Linux. OpenMCL and Lispworks versions -will come soon. +CMUCL 19a, SBCL 0.8.13, OpemMCL 0.14.2, or Allegro CL 6.2. +I've tested under FreeBSD, Linux and OpenMCL / Darwin. A +Lispworks version will come if requested. ASDF - http://www.cliki.net/asdf Index: elephant/ChangeLog diff -u elephant/ChangeLog:1.1 elephant/ChangeLog:1.2 --- elephant/ChangeLog:1.1 Tue Aug 31 00:05:41 2004 +++ elephant/ChangeLog Thu Sep 2 17:11:58 2004 @@ -1,2 +1,4 @@ +9/02/2004 - Alpha 0.1-p1: OID counter bugfix, OpenMCL support. + 8/30/2004 - Alpha 0.1. From blee at common-lisp.net Thu Sep 2 15:19:18 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 02 Sep 2004 17:19:18 +0200 Subject: [elephant-cvs] CVS update: elephant/INSTALL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv6238 Modified Files: INSTALL Log Message: update of docs (for openmcl, revisions) Date: Thu Sep 2 17:19:17 2004 Author: blee Index: elephant/INSTALL diff -u elephant/INSTALL:1.7 elephant/INSTALL:1.8 --- elephant/INSTALL:1.7 Thu Sep 2 17:11:58 2004 +++ elephant/INSTALL Thu Sep 2 17:19:17 2004 @@ -9,15 +9,18 @@ ASDF - http://www.cliki.net/asdf -UFFI 1.4.24 - http://uffi.b9.com +UFFI 1.4.24/5 - http://uffi.b9.com I've patched src/functions.lisp to support some kinds of :out arguments. it is backwards-compatible so shouldn't -interfere with your existing work. I've contacted Kevin -Rosenberg about this, it will appear in a future release. +interfere with your existing work. It is included in +1.4.25, but just in case you have 1.4.24 I have included it. Sleepycat Berkeley DB 4.2 - http://www.sleepycat.com +The version number is important -- the headers have changed +siginificantly. + A C compiler. Presumably you have this if you installed Sleepycat. @@ -38,11 +41,11 @@ with the provided file. 2) Install Berkeley DB 4.2. You may actually already have -this installed. The version number is important. FreeBSD -has a port for this, as I'm sure do other BSDs (including -Darwin/Fink.) Take note of where libdb.so and db.h are -installed (usually /usr/local/BerekleyDB.4.2/lib/libdb.so -and /usr/local/BerekleyDB.4.2/include/db.h, or +this installed. FreeBSD has a port for this, as I'm sure +do other BSDs (including Darwin/Fink.) Take note of where +libdb.so and db.h are installed (usually +/usr/local/BerekleyDB.4.2/lib/libdb.so and +/usr/local/BerekleyDB.4.2/include/db.h, or /usr/local/lib/db42/libdb.so and /usr/local/include/db42/db.h.) @@ -54,7 +57,8 @@ /usr/local/share/common-lisp/elephant/ -or where you specified. +or where you specified. On Darwin / OS X you need to have +the developer tools installed. 4) Compile and load Elephant: @@ -72,9 +76,11 @@ errors", especially on SBCL. They are not issues, go ahead and redefine the constants. -Under CMUCL I sporadically get strange behavior which -indicates you might get better performance if you compile -everything again with everything loaded. +I can't seem to make OpenMCL not intern default keyword +values of my macros -- something which doesn't happen on +other implementations. I can't reproduce the issue except +for in my code, but expect (use-package "ELE")'s to produce +conflicting symbol warnings. ----------- Quick Start From blee at common-lisp.net Sat Sep 4 08:12:20 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:12:20 +0200 Subject: [elephant-cvs] CVS update: elephant/TODO Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv11686 Modified Files: TODO Log Message: update Date: Sat Sep 4 10:12:18 2004 Author: blee Index: elephant/TODO diff -u elephant/TODO:1.3 elephant/TODO:1.4 --- elephant/TODO:1.3 Thu Sep 2 17:11:58 2004 +++ elephant/TODO Sat Sep 4 10:12:18 2004 @@ -2,7 +2,8 @@ new counters in 4.3 (october) -understand the profiler / timer, tweak performance of CLOS stuff +understand the profiler / timer, tweak performance of CLOS +stuff tweak performance of transactions! @@ -23,3 +24,9 @@ lispy pointer arithmetic performance hacks: class / slot to ID + +tests tests tests + +this is not particularly a bug but: if you redefine the +persistent-object class, you will mess up any existing +persistent classes you've made. From blee at common-lisp.net Sat Sep 4 08:13:00 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:13:00 +0200 Subject: [elephant-cvs] CVS update: elephant/elephant-tests.asd Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv11712 Added Files: elephant-tests.asd Log Message: initial version Date: Sat Sep 4 10:13:00 2004 Author: blee From blee at common-lisp.net Sat Sep 4 08:13:14 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:13:14 +0200 Subject: [elephant-cvs] CVS update: elephant/elephant.asd Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv11738 Modified Files: elephant.asd Log Message: typo Date: Sat Sep 4 10:13:14 2004 Author: blee Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.4 elephant/elephant.asd:1.5 --- elephant/elephant.asd:1.4 Sun Aug 29 22:35:52 2004 +++ elephant/elephant.asd Sat Sep 4 10:13:14 2004 @@ -3,7 +3,7 @@ ;;; elephant.asd -- ASDF system definition for elephant ;;; ;;; Initial version 8/26/2004 by Ben Lee -;;; +;;; ;;; ;;; part of ;;; From blee at common-lisp.net Sat Sep 4 08:16:12 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:16:12 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12530/src Modified Files: classes.lisp Log Message: initialize-instance obj : forgot to cache instances initialize-instance class => shared-initialize : reinitialize instance fixes shared-initialize obj : transients before persistents Date: Sat Sep 4 10:16:12 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.8 elephant/src/classes.lisp:1.9 --- elephant/src/classes.lisp:1.8 Thu Sep 2 16:41:25 2004 +++ elephant/src/classes.lisp Sat Sep 4 10:16:11 2004 @@ -50,7 +50,8 @@ "Sets the OID." (if (not from-oid) (setf (oid instance) (next-oid *store-controller*)) - (setf (oid instance) from-oid))) + (setf (oid instance) from-oid)) + (cache-instance *store-controller* instance)) (defclass persistent-object (persistent) ((%persistent-slots :transient t)) @@ -58,12 +59,32 @@ classes") (:metaclass persistent-metaclass)) -(defmethod initialize-instance :around ((class persistent-metaclass) &rest args &key direct-superclasses) +#| +(defmethod compute-class-precedence-list :around ((class persistent-metaclass)) + (let ((cpl (call-next-method)) + (persistent-object (find-class 'persistent-object))) + (if (member persistent-object cpl :test #'eq) + cpl + (let ((std-obj (find-class 'standard-object)) + (ccpl (copy-list cpl))) + (loop for c on ccpl + when (eq (cadr c) std-obj) + do + (setf (cdr c) (cons persistent-object + (cons (find-class 'persistent) (cdr c)))) + (return nil)) + ccpl)))) +|# + +(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) (let* ((persistent-metaclass (find-class 'persistent-metaclass)) + (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) - (if not-already-persistent - (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) + (if (and (not (eq class persistent-object)) not-already-persistent) + (apply #'call-next-method class slot-names + :direct-superclasses (cons persistent-object + direct-superclasses) args) (call-next-method)))) (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) @@ -79,6 +100,8 @@ (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) + ;; let the implementation initialize the transient slots + (apply #'call-next-method instance transient-slot-inits initargs) ;; initialize the persistent slots (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs @@ -96,9 +119,7 @@ (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))))) + (funcall initfun)))))))))) (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (declare (ignore class)) From blee at common-lisp.net Sat Sep 4 08:16:56 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:16:56 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12648/src Modified Files: controller.lisp Log Message: fixed macros Date: Sat Sep 4 10:16:56 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.7 elephant/src/controller.lisp:1.8 --- elephant/src/controller.lisp:1.7 Thu Sep 2 16:42:38 2004 +++ elephant/src/controller.lisp Sat Sep 4 10:16:55 2004 @@ -157,12 +157,13 @@ (setf (controller-environment sc) nil) nil) -(defmacro with-open-controller ((&optional (sc *store-controller*)) +(defmacro with-open-controller ((&optional (sc '*store-controller*)) &body body) `(unwind-protect (progn - (open-controller ,sc) - , at body) + (let (*store-controller* (open-controller ,sc)) + (declare (special *store-controller*)) + , at body)) (close-controller ,sc))) (defun open-store (path) @@ -170,4 +171,16 @@ (open-controller *store-controller*)) (defun close-store () - (close-controller *store-controller*)) \ No newline at end of file + (close-controller *store-controller*)) + +(defmacro with-open-store ((path) &body body) + (let ((sc (gensym))) + `(let ((,sc (make-instance 'store-controller :path ,path))) + (unwind-protect + (progn + (let ((*store-controller* ,sc)) + (declare (special *store-controller*)) + (open-controller *store-controller*) + , at body)) + (close-controller ,sc))))) + From blee at common-lisp.net Sat Sep 4 08:17:25 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:17:25 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12700/src Modified Files: elephant.lisp Log Message: update Date: Sat Sep 4 10:17:24 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.9 elephant/src/elephant.lisp:1.10 --- elephant/src/elephant.lisp:1.9 Thu Sep 2 16:47:53 2004 +++ elephant/src/elephant.lisp Sat Sep 4 10:17:24 2004 @@ -45,7 +45,7 @@ (:use common-lisp sleepycat) (:shadow #:with-transaction) (:export #:*store-controller* #:*current-transaction* #:*auto-commit* - #:open-store #:close-store + #: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 @@ -62,6 +62,7 @@ ) #+cmu (:import-from :pcl + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -69,6 +70,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -91,8 +93,13 @@ (:import-from :ext make-weak-pointer weak-pointer-value finalize) + #+cmu + (:import-from :bignum + %bignum-ref) + #+sbcl (:import-from :sb-mop + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -100,6 +107,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -123,8 +131,13 @@ (:import-from :sb-ext make-weak-pointer weak-pointer-value finalize) + #+sbcl + (:import-from :sb-bignum + %bignum-ref) + #+allegro (:import-from :clos + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -132,6 +145,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -145,6 +159,7 @@ compute-effective-slot-definition-initargs) #+openmcl (:import-from :ccl + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -152,6 +167,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -173,6 +189,7 @@ %slot-definition-type) #+lispworks (:import-from :clos + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -180,6 +197,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots From blee at common-lisp.net Sat Sep 4 08:20:38 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:20:38 +0200 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12752/src Modified Files: serializer.lisp Log Message: +base-char+ => +char+ handle uninterned symbols / symbols in another package optimizations / fixes for bignums fill-pointers circularity fixes (big typo!) automatic numeric array definition types Date: Sat Sep 4 10:20:37 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.6 elephant/src/serializer.lisp:1.7 --- elephant/src/serializer.lisp:1.6 Sun Aug 29 22:40:49 2004 +++ elephant/src/serializer.lisp Sat Sep 4 10:20:37 2004 @@ -58,7 +58,7 @@ (defconstant +persistent+ (char-code #\P)) (defconstant +single-float+ (char-code #\F)) (defconstant +double-float+ (char-code #\D)) -(defconstant +base-char+ (char-code #\c)) +(defconstant +char+ (char-code #\c)) (defconstant +pathname+ (char-code #\p)) (defconstant +positive-bignum+ (char-code #\B)) (defconstant +negative-bignum+ (char-code #\b)) @@ -66,6 +66,7 @@ (defconstant +cons+ (char-code #\C)) (defconstant +hash-table+ (char-code #\H)) (defconstant +object+ (char-code #\O)) + (defconstant +array+ (char-code #\A)) (defconstant +fill-pointer-p+ #x40) @@ -90,7 +91,11 @@ (declare (type string s) (dynamic-extent s)) (buffer-write-byte +symbol+ bs) (buffer-write-int (byte-length s) bs) - (buffer-write-string s bs))) + (buffer-write-string s bs) + (let ((package (symbol-package frob))) + (if package + (%serialize (package-name package)) + (%serialize nil))))) (string (buffer-write-byte +string+ bs) (buffer-write-int (byte-length frob) bs) @@ -107,9 +112,9 @@ (buffer-write-byte +double-float+ bs) (buffer-write-double frob bs)) (character - (buffer-write-byte +base-char+ bs) + (buffer-write-byte +char+ bs) ;; might be wide! - (buffer-write-int (char-code frob) bs)) + (buffer-write-uint (char-code frob) bs)) (pathname (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) @@ -125,14 +130,15 @@ (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) (buffer-write-int needed bs) - (loop for i fixnum from 0 to word-size - for byte-spec = (int-byte-spec i) + (loop for i fixnum from 0 below word-size ;; this ldb is consing on CMUCL! ;; there is an OpenMCL function which should work ;; and non-cons - for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num) - do - (buffer-write-uint the-uint bs)))) + do + #+(or cmu sbcl) + (buffer-write-uint (%bignum-ref num i) bs) + #+(or allegro lispworks openmcl) + (buffer-write-uint (ldb (int-byte-spec i) num) bs)))) (rational (buffer-write-byte +rational+ bs) (%serialize (numerator frob)) @@ -194,6 +200,8 @@ (loop for i fixnum from 0 below rank do (buffer-write-int (array-dimension frob i) bs))) + (when (array-has-fill-pointer-p frob) + (buffer-write-int (fill-pointer frob) bs)) (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) @@ -233,7 +241,11 @@ (buffer-read-fixnum bs)) ((= tag +nil+) nil) ((= tag +symbol+) - (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) + (let ((name (buffer-read-string bs (buffer-read-fixnum bs))) + (maybe-package-name (%deserialize bs))) + (if maybe-package-name + (intern name (find-package maybe-package-name)) + (make-symbol name)))) ((= tag +string+) (buffer-read-string bs (buffer-read-fixnum bs))) ((= tag +persistent+) @@ -244,8 +256,8 @@ (buffer-read-float bs)) ((= tag +double-float+) (buffer-read-double bs)) - ((= tag +base-char+) - (code-char (buffer-read-byte bs))) + ((= tag +char+) + (code-char (buffer-read-uint bs))) ((= tag +pathname+) (parse-namestring (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) @@ -273,6 +285,7 @@ :rehash-size (%deserialize bs) :rehash-threshold (%deserialize bs)))) + (setf (gethash id *circularity-hash*) h) (loop for i fixnum from 0 below (%deserialize bs) do (setf (gethash (%deserialize bs) h) @@ -283,6 +296,7 @@ (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)) @@ -303,6 +317,9 @@ flags)) :adjustable (/= 0 (logand +adjustable-p+ flags))))) + (when (array-has-fill-pointer-p a) + (setf (fill-pointer a) (buffer-read-int bs))) + (setf (gethash id *circularity-hash*) a) (loop for i fixnum from 0 below (array-total-size a) do (setf (row-major-aref a i) (%deserialize bs))) @@ -315,7 +332,7 @@ (type buffer-stream bs) (type fixnum length) (type boolean positive)) - (loop for i from 0 upto (/ length 4) + (loop for i from 0 below (/ length 4) for byte-spec = (int-byte-spec i) with num integer = 0 do @@ -330,22 +347,27 @@ (defvar byte-to-array-type (make-hash-table :test 'equalp)) (setf (gethash 'T array-type-to-byte) #x00) -(setf (gethash 'bit array-type-to-byte) #x01) -(setf (gethash '(unsigned-byte 2) array-type-to-byte) #x02) -(setf (gethash '(unsigned-byte 4) array-type-to-byte) #x03) -(setf (gethash '(unsigned-byte 8) array-type-to-byte) #x04) -(setf (gethash '(unsigned-byte 16) array-type-to-byte) #x05) -(setf (gethash '(unsigned-byte 32) array-type-to-byte) #x06) -(setf (gethash '(unsigned-byte 64) array-type-to-byte) #x07) -(setf (gethash '(signed-byte 8) array-type-to-byte) #x08) -(setf (gethash '(signed-byte 16) array-type-to-byte) #x09) -(setf (gethash '(signed-byte 32) array-type-to-byte) #x0A) -(setf (gethash '(signed-byte 64) array-type-to-byte) #x0B) -(setf (gethash 'character array-type-to-byte) #x0C) -(setf (gethash 'single-float array-type-to-byte) #x0D) -(setf (gethash 'double-float array-type-to-byte) #x0E) -(setf (gethash '(complex single-float) array-type-to-byte) #x0F) -(setf (gethash '(complex double-float) array-type-to-byte) #x10) +(setf (gethash 'base-char array-type-to-byte) #x01) +(setf (gethash 'character array-type-to-byte) #x02) +(setf (gethash 'single-float array-type-to-byte) #x03) +(setf (gethash 'double-float array-type-to-byte) #x04) +(setf (gethash '(complex single-float) array-type-to-byte) #x05) +(setf (gethash '(complex double-float) array-type-to-byte) #x06) +(setf (gethash 'fixnum array-type-to-byte) #x07) +(setf (gethash 'bit array-type-to-byte) #x08) +(let ((counter 8)) + (loop for i from 2 to 65 + for spec = (list 'unsigned-byte i) + for uspec = (upgraded-array-element-type spec) + unless (gethash uspec array-type-to-byte) + do + (setf (gethash uspec array-type-to-byte) (incf counter))) + (loop for i from 2 to 65 + for spec = (list 'signed-byte i) + for uspec = (upgraded-array-element-type spec) + unless (gethash uspec array-type-to-byte) + do + (setf (gethash uspec array-type-to-byte) (incf counter)))) (loop for key being the hash-key of array-type-to-byte using (hash-value value) From blee at common-lisp.net Sat Sep 4 08:23:31 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:23:31 +0200 Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12847/src Modified Files: utils.lisp Log Message: fixed macro arg (dynamic, not lexical) / typo fixed finalizer in allegro (don't close over the value or it will never be collected) Date: Sat Sep 4 10:23:30 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.4 elephant/src/utils.lisp:1.5 --- elephant/src/utils.lisp:1.4 Thu Sep 2 16:47:31 2004 +++ elephant/src/utils.lisp Sat Sep 4 10:23:30 2004 @@ -121,8 +121,8 @@ ;; Good defaults for elephant (defmacro with-transaction ((&key transaction - (environment (controller-environment - *store-controller*)) + (environment '(controller-environment + *store-controller*)) (parent '*current-transaction*) dirty-read txn-nosync txn-nowait txn-sync @@ -135,7 +135,7 @@ :txn-nosync ,txn-nosync :txn-nowait ,txn-nowait :txn-sync ,txn-sync - :retries ,100) + :retries ,retries) , at body)) @@ -165,15 +165,22 @@ (gethash key cache) ) +(defun make-finalizer (key cache) + #+(or cmu sbcl) + (lambda () (remhash key cache)) + #+allegro + (lambda (obj) (declare (ignore obj)) (remhash key cache)) + ) + (defun setf-cache (key cache value) #+(or cmu sbcl) (let ((w (make-weak-pointer value))) - (finalize value #'(lambda () (remhash key cache))) + (finalize value (make-finalizer key cache)) (setf (gethash key cache) w) value) #+allegro (progn - (excl:schedule-finalization value #'(lambda () (remhash key cache))) + (excl:schedule-finalization value (make-finalizer key cache)) (setf (gethash key cache) value)) #-(or cmu sbcl scl allegro) (setf (gethash key cache) value) From blee at common-lisp.net Sat Sep 4 08:24:23 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:24:23 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/mop-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv12882/tests Modified Files: mop-tests.lisp Log Message: made into RT tests, added a bunch Date: Sat Sep 4 10:24:23 2004 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.2 elephant/tests/mop-tests.lisp:1.3 --- elephant/tests/mop-tests.lisp:1.2 Thu Sep 2 09:30:12 2004 +++ elephant/tests/mop-tests.lisp Sat Sep 4 10:24:23 2004 @@ -1,93 +1,175 @@ -(use-package "ELE") +(in-package :ele-tests) +#+cmu +(import 'pcl::finalize-inheritance) +#+sbcl +(import 'sb-mop::finalize-inheritance) +#+allegro +(import 'clos::finalize-inheritance) +#+openmcl +(import 'ccl::finalize-inheritance) + +(deftest non-transient-class-slot-1 + (signals-condition + ;; This should fail (principle of least surprise) + (defclass non-transient-class-slot-1 () + ((slot3 :accessor slot3 :allocation :class)) + (:metaclass persistent-metaclass))) + t) + +(deftest non-transient-class-slot-2 + (signals-condition + ;; as should this + (defclass non-transient-class-slot-2 () + ((slot3 :accessor slot3 :allocation :class :transient nil)) + (:metaclass persistent-metaclass))) + t) + +(deftest transient-class-slot + (finishes + ;; but this should be fine + (defclass transient-class-slot () + ((slot3 :accessor slot3 :allocation :class :transient t)) + (:metaclass persistent-metaclass))) + t) + +(deftest class-definers + (finishes + (defclass p-class () + ((slot1 :accessor slot1) + (slot2 :accessor slot2 :transient t) + (slot3 :accessor slot3 :allocation :class :transient t)) + (:metaclass persistent-metaclass)) + (defclass nonp-class () + ((slot1 :accessor slot1) + (slot2 :accessor slot2) + (slot3 :accessor slot3 :allocation :class))) + (defclass minus-p-class () + ((slot1 :accessor slot1 :transient t) + (slot2 :accessor slot2) + (slot3 :accessor slot3)) + (:metaclass persistent-metaclass)) + (defclass switch-transient () + ((slot1 :accessor slot1 :transient t) + (slot2 :accessor slot2)) + (:metaclass persistent-metaclass)) + (defclass make-persistent () + ((slot2 :accessor slot2)) + (:metaclass persistent-metaclass))) + t) + +(deftest bad-inheritence + (signals-condition + ;; This should fail + (defclass bad-inheritence (p-class) ())) + t) + +(deftest mixes + (finishes + ;; but this should be fine + (defclass mix-1 (p-class nonp-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-1)) + ;; This should be ok + (defclass mix-2 (p-class minus-p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-2)) + ;; This should be ok + (defclass mix-3 (minus-p-class p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-3)) + ;; This should be ok + (defclass mix-4 (switch-transient p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-4)) + ;; This should be ok + (defclass mix-5 (p-class switch-transient) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-5)) + ;; should work + (defclass mix-6 (make-persistent p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-6))) + t) + +(deftest mixes-right-slots + (values + (typep (find-slot-def 'mix-1 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-1 'slot2) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-1 'slot3) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-2 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-2 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-2 'slot3) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-3 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-3 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-3 'slot3) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-4 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-4 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-4 'slot3) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-5 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-5 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-5 'slot3) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-6 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-6 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-6 'slot3) 'ele::transient-slot-definition)) + t t t t t t t t t t t t t t t t t t) + +(deftest inherit + (finishes + (defclass make-persistent2 (p-class) + ((slot2 :accessor slot2) + (slot4 :accessor slot4 :transient t)) + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'make-persistent2))) + t) + +(deftest inherit-right-slots + (values + (typep (find-slot-def 'make-persistent2 'slot1) + 'ele::persistent-slot-definition) + (typep (find-slot-def 'make-persistent2 'slot2) + 'ele::persistent-slot-definition) + (typep (find-slot-def 'make-persistent2 'slot3) + 'ele::transient-slot-definition) + (typep (find-slot-def 'make-persistent2 'slot4) + 'ele::transient-slot-definition)) + t t t t) + +(deftest initform-classes + (finishes + (defclass p-initform-test () + ((slot1 :initform 10)) + (:metaclass persistent-metaclass)) + (defclass p-initform-test-2 () + ((slot1 :initarg :slot1 :initform 10)) + (:metaclass persistent-metaclass)) + ) + t) + +(deftest initform-test + (slot-value (make-instance 'p-initform-test) 'slot1) + 10) + +(deftest initarg-test + (values + (slot-value (make-instance 'p-initform-test-2) 'slot1) + (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1)) + 10 20) + +(deftest no-eval-initform + (finishes + (defclass no-eval-initform () + ((slot1 :initarg :slot1 :initform (error "Shouldn't be called"))) + (:metaclass persistent-metaclass)) + (make-instance 'no-eval-initform :slot1 "something") + t) + t) + +(deftest redefclass + (progn + (defclass redef () () (:metaclass persistent-metaclass)) + (defclass redef () () (:metaclass persistent-metaclass)) + (values (subtypep 'redef 'persistent-object))) + t) -;; This should fail (principle of least surprise) -(defclass non-transient-class-slot-1 () - ((slot3 :accessor slot3 :allocation :class)) - (:metaclass persistent-metaclass)) - -;; as should this -(defclass non-transient-class-slot-2 () - ((slot3 :accessor slot3 :allocation :class :transient nil)) - (:metaclass persistent-metaclass)) - -;; but this should be fine -(defclass non-transient-class-slot-3 () - ((slot3 :accessor slot3 :allocation :class :transient t)) - (:metaclass persistent-metaclass)) - - -(defclass p-class () - ((slot1 :accessor slot1) - (slot2 :accessor slot2 :transient t) - (slot3 :accessor slot3 :allocation :class :transient t)) - (:metaclass persistent-metaclass)) - -(defclass nonp-class () - ((slot1 :accessor slot1) - (slot2 :accessor slot2) - (slot3 :accessor slot3 :allocation :class))) - -(defclass minus-p-class () - ((slot1 :accessor slot1 :transient t) - (slot2 :accessor slot2) - (slot3 :accessor slot3)) - (:metaclass persistent-metaclass)) - -;; This should fail -(defclass bad-inheritence (p-class) ()) - -;; but this should be fine -(defclass mix-1 (p-class nonp-class) () - (:metaclass persistent-metaclass)) - - -;; This should be ok -(defclass mix-2 (p-class minus-p-class) () - (:metaclass persistent-metaclass)) - -;; This should be ok -(defclass mix-3 (minus-p-class p-class) () - (:metaclass persistent-metaclass)) - -(defclass switch-transient () - ((slot1 :accessor slot1 :transient t) - (slot2 :accessor slot2)) - (:metaclass persistent-metaclass)) - -;; This should be ok -(defclass mix-4 (switch-transient p-class) () - (:metaclass persistent-metaclass)) - -;; This should be ok -(defclass mix-5 (p-class switch-transient) () - (:metaclass persistent-metaclass)) - -(defclass make-persistent () - ((slot2 :accessor slot2)) - (:metaclass persistent-metaclass)) - -;; should work -(defclass mix-6 (make-persistent p-class) () - (:metaclass persistent-metaclass)) - -(defclass make-persistent2 (p-class) - ((slot2 :accessor slot2) - (slot4 :accessor slot4 :transient t)) - (:metaclass persistent-metaclass)) - - -(defclass initform-test () - ((slot1 :initform 10))) - -(defclass p-initform-test () - ((slot1 :initform 10)) - (:metaclass persistent-metaclass)) - -(defclass p-initform-test-2 () - ((slot1 :initarg :slot1 :initform 10)) - (:metaclass persistent-metaclass)) - -(setq pf (make-instance 'p-initform-test-2)) -(slot-value pf 'slot1) -(setq pf (make-instance 'p-initform-test-2 :slot1 20)) -(slot-value pf 'slot1) +(with-open-store (*testdb-path*) + (do-tests)) From blee at common-lisp.net Sat Sep 4 08:24:31 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:24:31 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv12903/tests Added Files: elephant-tests.lisp Log Message: initial version Date: Sat Sep 4 10:24:30 2004 Author: blee From blee at common-lisp.net Sat Sep 4 08:25:13 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:25:13 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testserializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv12983/tests Modified Files: testserializer.lisp Log Message: made into RT tests, added a bunch Date: Sat Sep 4 10:25:08 2004 Author: blee Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.2 elephant/tests/testserializer.lisp:1.3 --- elephant/tests/testserializer.lisp:1.2 Thu Sep 2 09:32:16 2004 +++ elephant/tests/testserializer.lisp Sat Sep 4 10:25:07 2004 @@ -1,27 +1,367 @@ -(in-package "ELE") +(in-package :ele-tests) +(import 'ele::*out-buf*) +(import 'ele::serialize) +(import 'ele::deserialize) +(import 'ele::buffer-stream-buffer) -(defun test (var) +(defun in-out-value (var) (serialize var *out-buf*) (deserialize (buffer-stream-buffer *out-buf*))) -(= 10000000000 (test 10000000000)) +(defun in-out-eq (var) + (serialize var *out-buf*) + (eq var (deserialize (buffer-stream-buffer *out-buf*)))) + +(defun in-out-equal (var) + (serialize var *out-buf*) + (equal var (deserialize (buffer-stream-buffer *out-buf*)))) + +(defun in-out-equalp (var) + (serialize var *out-buf*) + (equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + +(deftest fixnums + (values + (in-out-equal 0) + (in-out-equal -1) + (in-out-equal 1) + (in-out-equal most-positive-fixnum) + (in-out-equal most-negative-fixnum)) + t t t t t) + +(deftest fixnum-type-1 + (values + (typep (in-out-value 0) 'fixnum) + (typep (in-out-value 1) 'fixnum) + (typep (in-out-value -1) 'fixnum) + (typep (in-out-value most-positive-fixnum) 'fixnum) + (typep (in-out-value most-negative-fixnum) 'fixnum)) + t t t t t) + +(deftest bignums + (values + (in-out-equal 10000000000) + (in-out-equal -10000000000) + (loop for i from 0 to 2000 + always (in-out-equal (expt 2 i))) + (loop for i from 0 to 2000 + always (in-out-equal (- (expt 2 i)))) + (loop for i from 0 to 2000 + always (in-out-equal (- (expt 2 i) 1))) + (loop for i from 0 to 2000 + always (in-out-equal (- 1 (expt 2 i)))) + (loop for i from 0 to 2000 + always (in-out-equal (expt 3 i))) + (loop for i from 0 to 2000 + always (in-out-equal (- (expt 3 i))))) + t t t t t t t t) + +(deftest floats + (values + (in-out-equal 0.0) + (in-out-equal -0.0) + (in-out-equal 0.0d0) + (in-out-equal -0.0d0) + (in-out-equal -0.0d0) + (in-out-equal double-float-epsilon) + (in-out-equal long-float-epsilon) + (in-out-equal short-float-epsilon) + (in-out-equal single-float-epsilon) + (in-out-equal double-float-negative-epsilon) + (in-out-equal long-float-negative-epsilon) + (in-out-equal short-float-negative-epsilon) + (in-out-equal single-float-negative-epsilon) + (in-out-equal least-negative-double-float) + (in-out-equal least-negative-long-float) + (in-out-equal least-negative-short-float) + (in-out-equal least-negative-single-float) + (in-out-equal least-positive-double-float) + (in-out-equal least-positive-long-float) + (in-out-equal least-positive-short-float) + (in-out-equal least-positive-single-float) + (in-out-equal most-negative-double-float) + (in-out-equal most-negative-long-float) + (in-out-equal most-negative-short-float) + (in-out-equal most-negative-single-float) + (in-out-equal most-positive-double-float) + (in-out-equal most-positive-long-float) + (in-out-equal most-positive-short-float) + (in-out-equal most-positive-single-float)) + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t) + +(deftest rationals + (values + (in-out-equal 1/2) + (in-out-equal -1/2) + (in-out-equal (/ 1 most-positive-fixnum)) + (in-out-equal (/ 1 most-negative-fixnum)) + (in-out-equal (/ most-positive-fixnum most-negative-fixnum)) + (in-out-equal (/ (expt 2 200) (expt 3 300))) + (in-out-equal (/ (expt 2 200) (- (expt 3 300))))) + t t t t t t t) + +(deftest strings + (values + (in-out-equal "") + (in-out-equal "this is a test") + (in-out-equal (make-string 400 :initial-element (code-char 254)))) + t t t) + +(defun in-out-uninterned-equal (var) + (serialize var *out-buf*) + (let ((new (deserialize (buffer-stream-buffer *out-buf*)))) + (and (equal (symbol-name new) (symbol-name var)) + (equal (symbol-package new) (symbol-package var))))) + +(deftest symbols + (values + (in-out-equal nil) + (in-out-equal T) + (in-out-equal 'foobarbazquux) + (in-out-equal 'ele::next-oid) + (in-out-equal :a-keyword-symbol) + (in-out-uninterned-equal '#:foozle) + (in-out-uninterned-equal (make-symbol "a wha wah ba ba")) + (in-out-uninterned-equal (make-symbol ""))) + t t t t t t t t) + +(deftest chars + (loop for i from 0 below char-code-limit + unless (in-out-equal (code-char i)) + do (return i) + finally (return T)) + t) + +(deftest pathnames + ;;; Given how implementation-specific make-pathname is, + ;;; i don't know how to put more portable tests here! + (values + (in-out-equal #p"/usr/local/share/common-lisp/elephant")) + t) + +(deftest conses + (values + (in-out-equal (cons t 100000)) + (in-out-equal (list 1 'a "this is a test" 'c 10000 nil 1000 nil)) + (in-out-equal (cons (cons (cons t nil) (cons nil t)) (cons 1 (cons t nil)))) + ) + t t t) + +(deftest hash-tables-1 + (let* ((ht (make-hash-table :test 'equalp :size 333 :rehash-size 1.2 + :rehash-threshold 0.8)) + (size (hash-table-size ht)) + (rehash-size (hash-table-rehash-size ht)) + (rehash-threshold (hash-table-rehash-threshold ht)) + (out (in-out-value ht))) + (values + (eq (hash-table-test out) 'equalp) + (= (hash-table-size ht) size) + (= (hash-table-rehash-size ht) rehash-size) + (= (hash-table-rehash-threshold ht) rehash-threshold) + (eq (hash-table-test (in-out-value (make-hash-table :test 'eq))) 'eq) + (eq (hash-table-test (in-out-value (make-hash-table :test 'eql))) 'eql) + (eq (hash-table-test + (in-out-value (make-hash-table :test 'equal))) 'equal) + (eq (hash-table-test + (in-out-value (make-hash-table :test 'equalp))) 'equalp))) + t t t t t t t t) + +(deftest hash-tables-2 + (let ((ht (make-hash-table :test 'equalp))) + (setf (gethash (cons nil nil) ht) "one") + (setf (gethash 2 ht) 2.0d0) + (setf (gethash 'symbolsymbol ht) "three") + (let ((out (in-out-value ht))) + (values + (string= (gethash (cons nil nil) ht) "one") + (= (gethash 2 ht) 2.0d0) + (string= (gethash 'symbolsymbol ht) "three")))) + t t t) + +(defun type= (t1 t2) + (and (subtypep t1 t2) (subtypep t2 t1))) + +(deftest arrays-1 + (values + (array-has-fill-pointer-p + (in-out-value (make-array 200 :fill-pointer t))) + (not (array-has-fill-pointer-p + (in-out-value (make-array 200 :fill-pointer nil)))) + (type= (upgraded-array-element-type '(unsigned-byte 20)) + (array-element-type + (in-out-value (make-array '(3 4 5) + :element-type + '(unsigned-byte 20))))) + (type= (upgraded-array-element-type 'fixnum) + (array-element-type + (in-out-value (make-array '(3 4 5) + :element-type + 'fixnum)))) + ) + t t t t) + +(deftest arrays-2 + (let ((arr (make-array '(3 4 5))) + (vec (make-array 100 :adjustable t :fill-pointer t)) + (svec (make-array 100 :adjustable nil :fill-pointer nil))) + (setf (aref arr 0 0 0) 'symb) + (setf (aref arr 1 2 3) 123132) + (setf (aref arr 2 3 4) "this is a longish string") + (vector-push-extend 123456789101112 vec) + (vector-push-extend "mr t" vec) + (vector-push-extend 'symbolic vec) + (loop for i from 0 to 99 + do + (setf (svref svec i) (expt 2 i))) + (values + (in-out-equalp arr) + (in-out-equalp vec) + (in-out-equalp svec) + (typep (in-out-value svec) 'simple-vector))) + t t t t) + + +;; depends on ele::slots-and-values +(defun deep-equalp (thing another) + (let ((seen (make-hash-table :test 'eq))) + (labels + ((%deep-equalp (s1 s2) + (when (type= (type-of s1) (type-of s2)) + (if (gethash s1 seen) t + (progn + (setf (gethash s1 seen) t) + (typecase s1 + (cons + (and (%deep-equalp (car s1) (car s2)) + (%deep-equalp (cdr s1) (cdr s2)))) + (array + (loop for i from 0 below (array-total-size s1) + always (%deep-equalp + (row-major-aref s1 i) + (row-major-aref s2 i)))) + (hash-table + (when (= (hash-table-count s1) + (hash-table-count s2)) + (loop for key being the hash-key of s1 + using (hash-value value) + always (%deep-equalp value + (gethash key s2))))) + (standard-object + (%deep-equalp (ele::slots-and-values s1) + (ele::slots-and-values s2))) + (t (equalp s1 s2)))))))) + (%deep-equalp thing another)))) + +(defclass foo () + ((slot1 :initarg :slot1) + (slot2 :initarg :slot2))) + +(defclass bar () + ((slot1 :initarg :slot1) + (slot2 :initarg :slot2))) + +(deftest test-deep-equalp + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (l1 (make-list 100)) + (h (make-hash-table :test 'equal)) + (g (make-array '(2 3 4))) + (f (make-instance 'foo)) + (b (make-instance 'bar))) + (setf (car c1) c1) + (setf (cdr c1) c1) + (setf (car c2) c1) + (setf (cdr c2) c2) + (setf (cdr (last l1)) l1) + (setf (gethash "quux" h) l1) + (setf (gethash "bar" h) c2) + (setf (aref g 1 1 1) g) + (setf (aref g 0 0 1) h) + (setf (gethash "foo" h) g) + (setf (slot-value f 'slot1) b) + (setf (slot-value f 'slot2) f) + (setf (slot-value b 'slot1) h) + (setf (slot-value b 'slot2) f) + (values + (deep-equalp c1 c1) + (deep-equalp c2 c2) + (deep-equalp l1 l1) + (deep-equalp h h) + (deep-equalp g g) + (deep-equalp f f) + (deep-equalp b b))) + t t t t t t t) + +(defun in-out-deep-equalp (var) + (serialize var *out-buf*) + (deep-equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + +(deftest objects + (values + (in-out-deep-equalp (make-instance 'foo)) + (in-out-deep-equalp (make-instance 'bar :slot1 + (make-instance 'foo + :slot2 "foo bar")))) + t t) + +(deftest circular + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (l1 (make-list 100)) + (h (make-hash-table :test 'equal)) + (g (make-array '(2 3 4))) + (f (make-instance 'foo)) + (b (make-instance 'bar))) + (setf (car c1) c1) + (setf (cdr c1) c1) + (setf (car c2) c1) + (setf (cdr c2) c2) + (setf (cdr (last l1)) l1) + (setf (gethash "quux" h) l1) + (setf (gethash "bar" h) c2) + (setf (aref g 1 1 1) g) + (setf (aref g 0 0 1) h) + (setf (gethash "foo" h) g) + (setf (slot-value f 'slot1) b) + (setf (slot-value f 'slot2) f) + (setf (slot-value b 'slot1) h) + (setf (slot-value b 'slot2) f) + (values + (in-out-deep-equalp c1) + (in-out-deep-equalp c2) + (in-out-deep-equalp l1) + (in-out-deep-equalp h) + (in-out-deep-equalp g) + (in-out-deep-equalp f) + (in-out-deep-equalp b))) + t t t t t t t) -(equalp (cons 10000000000 10000000000) - (test (cons 10000000000 10000000000))) +(defclass pfoo () + ((slot1 :initarg :slot1 :accessor slot1)) + (:metaclass persistent-metaclass)) -(setq f (cons nil nil)) -(prog1 t (setf (car f) f)) -(prog1 t (setq g (test f))) -(eq g (car g)) -(eq nil (cdr g)) - -(setq h (make-hash-table :test 'eql)) -(prog1 t (setf (gethash 10000000000 h) f)) -(setq h2 (test h)) -(= 1 (hash-table-count h2)) -(prog1 t (setq g (gethash 10000000000 h2))) -(eq g (car g)) -(eq nil (cdr g)) +(defclass pbar (pfoo) + ((slot2 :initarg :slot2 :accessor slot2)) + (:metaclass persistent-metaclass)) -;(defclass foo () -; ((slot1 :type \ No newline at end of file +(deftest persistent + (let ((f1 (make-instance 'pfoo)) + (f2 (make-instance 'pfoo :slot1 "this is a string")) + (b1 (make-instance 'pbar :slot2 "another string")) + (b2 (make-instance 'pbar)) + (h (make-instance 'btree))) + (values + (in-out-eq f1) + (in-out-eq f2) + (in-out-eq b1) + (in-out-eq b2) + (in-out-eq h) + (signals-condition + (slot1 f1)) + (progn (setf (slot1 f1) f1) + (eq f1 (slot1 f1))) + (progn (setf (get-value f2 h) f2) + (eq (get-value f2 h) f2)))) + t t t t t t t t) + \ No newline at end of file From blee at common-lisp.net Sat Sep 4 08:25:22 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:25:22 +0200 Subject: [elephant-cvs] CVS update: Directory change: elephant/tests/testdb Message-ID: Update of /project/elephant/cvsroot/elephant/tests/testdb In directory common-lisp.net:/tmp/cvs-serv13030/tests/testdb Log Message: Directory /project/elephant/cvsroot/elephant/tests/testdb added to the repository Date: Sat Sep 4 10:25:18 2004 Author: blee New directory elephant/tests/testdb added From blee at common-lisp.net Sat Sep 4 08:28:45 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:28:45 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv14824/src Modified Files: controller.lisp Log Message: incorporated Rafal Strzalinski's fix (don't close environments / db's twice) Date: Sat Sep 4 10:28:45 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.8 elephant/src/controller.lisp:1.9 --- elephant/src/controller.lisp:1.8 Sat Sep 4 10:16:55 2004 +++ elephant/src/controller.lisp Sat Sep 4 10:28:44 2004 @@ -146,16 +146,17 @@ (defmethod close-controller ((sc store-controller)) "Close the db handles and environment. Tries to wipe out references to the db handles." - ; no root - (setf (slot-value sc 'root) nil) - ; clean instance cache - (setf (instance-cache sc) (make-cache-table :test 'eql)) - ; close environment - (db-close (controller-db sc)) - (setf (controller-db sc) nil) - (db-env-close (controller-environment sc)) - (setf (controller-environment sc) nil) - nil) + (when (slot-value sc 'root) + ;; no root + (setf (slot-value sc 'root) nil) + ;; clean instance cache + (setf (instance-cache sc) (make-cache-table :test 'eql)) + ;; close environment + (db-close (controller-db sc)) + (setf (controller-db sc) nil) + (db-env-close (controller-environment sc)) + (setf (controller-environment sc) nil) + nil)) (defmacro with-open-controller ((&optional (sc '*store-controller*)) &body body) From blee at common-lisp.net Sat Sep 4 08:59:42 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 10:59:42 +0200 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22085/src Modified Files: serializer.lisp Log Message: really fixed the array types (hopefully!) Date: Sat Sep 4 10:59:40 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.7 elephant/src/serializer.lisp:1.8 --- elephant/src/serializer.lisp:1.7 Sat Sep 4 10:20:37 2004 +++ elephant/src/serializer.lisp Sat Sep 4 10:59:40 2004 @@ -355,19 +355,23 @@ (setf (gethash '(complex double-float) array-type-to-byte) #x06) (setf (gethash 'fixnum array-type-to-byte) #x07) (setf (gethash 'bit array-type-to-byte) #x08) + +(defun type= (t1 t2) + (and (subtypep t1 t2) (subtypep t2 t1))) + (let ((counter 8)) (loop for i from 2 to 65 for spec = (list 'unsigned-byte i) for uspec = (upgraded-array-element-type spec) - unless (gethash uspec array-type-to-byte) + when (type= spec uspec) do - (setf (gethash uspec array-type-to-byte) (incf counter))) + (setf (gethash spec array-type-to-byte) (incf counter))) (loop for i from 2 to 65 for spec = (list 'signed-byte i) for uspec = (upgraded-array-element-type spec) - unless (gethash uspec array-type-to-byte) + when (type= spec uspec) do - (setf (gethash uspec array-type-to-byte) (incf counter)))) + (setf (gethash spec array-type-to-byte) (incf counter)))) (loop for key being the hash-key of array-type-to-byte using (hash-value value) From blee at common-lisp.net Sat Sep 4 09:03:38 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 11:03:38 +0200 Subject: [elephant-cvs] CVS update: elephant/Makefile Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv22981 Modified Files: Makefile Log Message: back to Linux default Date: Sat Sep 4 11:03:38 2004 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.2 elephant/Makefile:1.3 --- elephant/Makefile:1.2 Thu Sep 2 09:03:51 2004 +++ elephant/Makefile Sat Sep 4 11:03:37 2004 @@ -7,13 +7,13 @@ SHELL=/bin/sh UNAME:=$(shell uname -s) -# *BSD users will probably want -DBLIBDIR=/usr/local/lib/db42 -DBINCDIR=/usr/local/include/db42 +DB42DIR=/usr/local/BerkeleyDB.4.2 +DBLIBDIR=$(DB42DIR)/lib/ +DBINCDIR=$(DB42DIR)/include/ -#DB42DIR=/usr/local/BerkeleyDB.4.2 -#DBLIBDIR=$(DB42DIR)/lib/ -#DBINCDIR=$(DB42DIR)/include/ +# *BSD users will probably want +#DBLIBDIR=/usr/local/lib/db42 +#DBINCDIR=/usr/local/include/db42 INSTALLDIR=/usr/local/share/common-lisp/elephant-0.1/ From blee at common-lisp.net Sat Sep 4 09:16:15 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 04 Sep 2004 11:16:15 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp elephant/tests/mop-tests.lisp elephant/tests/testserializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv27360/tests Modified Files: elephant-tests.lisp mop-tests.lisp testserializer.lisp Log Message: fixed imports Date: Sat Sep 4 11:16:11 2004 Author: blee Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.1 elephant/tests/elephant-tests.lisp:1.2 --- elephant/tests/elephant-tests.lisp:1.1 Sat Sep 4 10:24:30 2004 +++ elephant/tests/elephant-tests.lisp Sat Sep 4 11:16:11 2004 @@ -43,24 +43,34 @@ (defpackage elephant-tests (:nicknames ele-tests :ele-tests) (:use common-lisp elephant rt) + (:import-from :ele + *out-buf* + serialize + deserialize + buffer-stream-buffer) #+cmu (:import-from :pcl + finalize-inheritance slot-definition-name class-slots) #+sbcl (:import-from :sb-mop + finalize-inheritance slot-definition-name class-slots) #+allegro (:import-from :clos + finalize-inheritance slot-definition-name class-slots) #+openmcl (:import-from :ccl + finalize-inheritance slot-definition-name class-slots) #+lispworks (:import-from :clos + finalize-inheritance slot-definition-name class-slots) ) Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.3 elephant/tests/mop-tests.lisp:1.4 --- elephant/tests/mop-tests.lisp:1.3 Sat Sep 4 10:24:23 2004 +++ elephant/tests/mop-tests.lisp Sat Sep 4 11:16:11 2004 @@ -1,12 +1,4 @@ (in-package :ele-tests) -#+cmu -(import 'pcl::finalize-inheritance) -#+sbcl -(import 'sb-mop::finalize-inheritance) -#+allegro -(import 'clos::finalize-inheritance) -#+openmcl -(import 'ccl::finalize-inheritance) (deftest non-transient-class-slot-1 (signals-condition Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.3 elephant/tests/testserializer.lisp:1.4 --- elephant/tests/testserializer.lisp:1.3 Sat Sep 4 10:25:07 2004 +++ elephant/tests/testserializer.lisp Sat Sep 4 11:16:11 2004 @@ -1,8 +1,4 @@ (in-package :ele-tests) -(import 'ele::*out-buf*) -(import 'ele::serialize) -(import 'ele::deserialize) -(import 'ele::buffer-stream-buffer) (defun in-out-value (var) (serialize var *out-buf*) From blee at common-lisp.net Thu Sep 16 04:11:02 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:11:02 +0200 Subject: [elephant-cvs] CVS update: elephant/Makefile Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24722 Modified Files: Makefile Log Message: libmath, bumped version Date: Thu Sep 16 06:11:01 2004 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.3 elephant/Makefile:1.4 --- elephant/Makefile:1.3 Sat Sep 4 11:03:37 2004 +++ elephant/Makefile Thu Sep 16 06:11:00 2004 @@ -15,7 +15,7 @@ #DBLIBDIR=/usr/local/lib/db42 #DBINCDIR=/usr/local/include/db42 -INSTALLDIR=/usr/local/share/common-lisp/elephant-0.1/ +INSTALLDIR=/usr/local/share/common-lisp/elephant-0.2/ ifeq (Darwin,$(UNAME)) SHARED=-bundle @@ -24,7 +24,7 @@ endif libsleepycat.so: src/libsleepycat.c - gcc $(SHARED) -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb + gcc $(SHARED) -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm install: libsleepycat.so install $< $(INSTALLDIR) From blee at common-lisp.net Thu Sep 16 04:11:22 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:11:22 +0200 Subject: [elephant-cvs] CVS update: elephant/TODO Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24749 Modified Files: TODO Log Message: updates Date: Thu Sep 16 06:11:21 2004 Author: blee Index: elephant/TODO diff -u elephant/TODO:1.4 elephant/TODO:1.5 --- elephant/TODO:1.4 Sat Sep 4 10:12:18 2004 +++ elephant/TODO Thu Sep 16 06:11:21 2004 @@ -5,11 +5,26 @@ understand the profiler / timer, tweak performance of CLOS stuff -tweak performance of transactions! +tweak performance of transactions! dynamic-extent in CMUCL +/ SBCL. more documentation: reference! -secondary index generation, cursors +secondary index generation, cursors: + +- secondary indices on the "lisp" side : minor / nil +performance gains and DB handle badness for DB->associate + +- create 2 DBs per sorting function: primary and secondary, +without and with duplicates. + +- in addition to the usual lexicographic sorter, create a +"lisp" version -- sorts primitive types (numbers, strings, +symbols.) use http://oss.software.ibm.com/icu/ for 16-bit +unicode. + +- equality joins have to be done on the lisp side: +end-of-table is not the same as end-of-btree. GC (need cursors) @@ -19,9 +34,9 @@ that ldb is non-consing (i think it is), look at %ldb-fixnum-from-bignum) -serialize lambdas, closures, packages..... +serialize lambdas, closures, packages.....this is hard! -lispy pointer arithmetic +lispy pointer arithmetic (profile sap-alien, etc) performance hacks: class / slot to ID @@ -30,3 +45,12 @@ this is not particularly a bug but: if you redefine the persistent-object class, you will mess up any existing persistent classes you've made. + +CMUCL, SBCL, Allegro? (NOT OpenMCL) can directly pass memory +like foreign arrays. Use these instead of foreign arrays? + +byte-ordering? nah..... + +incorporate requirements from ICU license + +cursor-put : move the cursor after insert. \ No newline at end of file From blee at common-lisp.net Thu Sep 16 04:11:43 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:11:43 +0200 Subject: [elephant-cvs] CVS update: elephant/elephant-tests.asd Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24776 Modified Files: elephant-tests.asd Log Message: testcollections Date: Thu Sep 16 06:11:42 2004 Author: blee Index: elephant/elephant-tests.asd diff -u elephant/elephant-tests.asd:1.1 elephant/elephant-tests.asd:1.2 --- elephant/elephant-tests.asd:1.1 Sat Sep 4 10:12:59 2004 +++ elephant/elephant-tests.asd Thu Sep 16 06:11:42 2004 @@ -56,6 +56,7 @@ ((:file "elephant-tests") (:file "testserializer") (:file "mop-tests") + (:file "testcollections") ;(:file "testsleepycat") ) :serial t))) From blee at common-lisp.net Thu Sep 16 04:12:41 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:12:41 +0200 Subject: [elephant-cvs] CVS update: elephant/elephant.asd Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24808 Modified Files: elephant.asd Log Message: berkeley-db license description Date: Thu Sep 16 06:12:41 2004 Author: blee Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.5 elephant/elephant.asd:1.6 --- elephant/elephant.asd:1.5 Sat Sep 4 10:13:14 2004 +++ elephant/elephant.asd Thu Sep 16 06:12:41 2004 @@ -45,14 +45,15 @@ :author "Ben Lee " :version "0.1" :maintainer "Ben Lee " - :licence "Lessor Lisp General Public License" + :licence "GPL" :description "Object database for Common Lisp" - :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, Lispworks, and Allegro." + :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro." :components ((:module :src :components ((:file "sleepycat") + (:file "berkeley-db") (:file "elephant") (:file "utils") (:file "metaclasses") From blee at common-lisp.net Thu Sep 16 04:14:04 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:14:04 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv24835/src Modified Files: classes.lisp Log Message: doc-strings slot-makunbound-using-class init transients after persistents Date: Thu Sep 16 06:14:04 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.9 elephant/src/classes.lisp:1.10 --- elephant/src/classes.lisp:1.9 Sat Sep 4 10:16:11 2004 +++ elephant/src/classes.lisp Thu Sep 16 06:14:04 2004 @@ -46,8 +46,8 @@ (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid) - (declare (ignore initargs)) "Sets the OID." + (declare (ignore initargs)) (if (not from-oid) (setf (oid instance) (next-oid *store-controller*)) (setf (oid instance) from-oid)) @@ -56,27 +56,12 @@ (defclass persistent-object (persistent) ((%persistent-slots :transient t)) (:documentation "Superclass of all user-defined persistent -classes") +classes. To make some slots not persisted, use the +:transient flag.") (:metaclass persistent-metaclass)) -#| -(defmethod compute-class-precedence-list :around ((class persistent-metaclass)) - (let ((cpl (call-next-method)) - (persistent-object (find-class 'persistent-object))) - (if (member persistent-object cpl :test #'eq) - cpl - (let ((std-obj (find-class 'standard-object)) - (ccpl (copy-list cpl))) - (loop for c on ccpl - when (eq (cadr c) std-obj) - do - (setf (cdr c) (cons persistent-object - (cons (find-class 'persistent) (cdr c)))) - (return nil)) - ccpl)))) -|# - (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) + "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses @@ -88,7 +73,11 @@ (call-next-method)))) (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) - "This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al aren't used." + "Initializes the persistent slots via initargs or forms. +This seems to be necessary because it is typical for +implementations to optimize setting the slots via initforms +and initargs in such a way that slot-value-using-class et al +aren't used. Calls the next method for the transient slots." (let* ((class (class-of instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) @@ -100,8 +89,6 @@ (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) - ;; let the implementation initialize the transient slots - (apply #'call-next-method instance transient-slot-inits initargs) ;; initialize the persistent slots (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs @@ -119,31 +106,41 @@ (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) - (funcall initfun)))))))))) + (funcall initfun)))))) + ;; let the implementation initialize the transient slots + (apply #'call-next-method instance transient-slot-inits initargs))))) (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) + "Get the slot value from the database." + (declare (optimize (speed 3)) + (ignore class)) (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name))) (defmethod (setf slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) + "Set the slot value in the database." + (declare (optimize (speed 3)) + (ignore class)) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name))) (defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) + "Checks if the slot exists in the database." + (declare (optimize (speed 3)) + (ignore class)) (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp instance name))) (defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) - (buffer-write-int (oid instance) *key-buf*) - (let ((key-length (serialize (slot-definition-name slot-def) *key-buf*))) + "Deletes the slot from the database." + (declare (optimize (speed 3)) + (ignore class)) + (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*) - (buffer-stream-buffer *key-buf*) - key-length + (controller-db *store-controller*) key-buf :transaction *current-transaction* - :auto-commit *auto-commit*))) + :auto-commit *auto-commit*)) + instance) From blee at common-lisp.net Thu Sep 16 04:14:45 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:14:45 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv24865/src Modified Files: collections.lisp Log Message: doc-strings secondary indices cursors Date: Thu Sep 16 06:14:44 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.6 elephant/src/collections.lisp:1.7 --- elephant/src/collections.lisp:1.6 Sun Aug 29 22:36:48 2004 +++ elephant/src/collections.lisp Thu Sep 16 06:14:44 2004 @@ -44,47 +44,774 @@ ;;; collection types ;;; we're slot-less -(defclass persistent-collection (persistent) - ()) +(defclass persistent-collection (persistent) () + (:documentation "Abstract superclass of all collection types.")) ;;; btree access -(defclass btree (persistent-collection) ()) +(defclass btree (persistent-collection) () + (:documentation "A hash-table like interface to a BTree, +which stores things in a semi-ordered fashion.")) (defgeneric get-value (key ht)) (defgeneric (setf get-value) (value key ht)) -(defgeneric remove-kv (key ht &key transaction auto-commit)) +(defgeneric remove-kv (key ht)) (defmethod get-value (key (ht btree)) - (declare (optimize (speed 3) (safety 0) (space 3))) - (buffer-write-int (oid ht) *key-buf*) - (let* ((key-length (serialize key *key-buf*)) - (buf (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length))) - (declare (type fixnum key-length)) - (if buf (values (deserialize buf) T) - (values nil nil)))) + "Get a value from a Btree." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (let ((buf (db-get-key-buffered + (controller-btrees *store-controller*) + key-buf value-buf))) + (if buf (values (deserialize buf) T) + (values nil nil))))) (defmethod (setf get-value) (value key (ht btree)) - (declare (optimize (speed 3) (safety 0))) - (buffer-write-int (oid ht) *key-buf*) - (let ((key-length (serialize key *key-buf*)) - (val-length (serialize value *out-buf*))) - (db-put-buffered (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) key-length - (buffer-stream-buffer *out-buf*) val-length - :transaction *current-transaction* + "Put a key / value pair into a BTree." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (db-put-buffered (controller-btrees *store-controller*) + key-buf value-buf :auto-commit *auto-commit*) value)) -(defmethod remove-kv (key (ht btree) - &key (transaction *current-transaction*) - (auto-commit *auto-commit*)) - (declare (optimize (speed 3) (safety 0))) - (buffer-write-int (oid ht) *key-buf*) - (let ((key-length (serialize key *key-buf*))) - (db-delete-buffered (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) key-length - :transaction transaction - :auto-commit auto-commit))) +(defmethod remove-kv (key (ht btree)) + "Remove a key / value pair from a BTree." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (db-delete-buffered (controller-btrees *store-controller*) + key-buf :auto-commit *auto-commit*))) + + +;; Secondary indices + +(defclass indexed-btree (btree) + ((indices :accessor indices :initform (make-hash-table)) + (indices-cache :accessor indices-cache :initform (make-hash-table) + :transient t)) + (:metaclass persistent-metaclass) + (:documentation "A BTree which supports secondary indices.")) + +(defmethod shared-initialize :after ((instance indexed-btree) slot-names + &rest rest) + (declare (ignore slot-names rest)) + (setf (indices-cache instance) (indices instance))) + +(defgeneric add-index (ht &key index-name key-form)) +(defgeneric get-index (ht index-name)) +(defgeneric remove-index (ht index-name)) + +(defmethod add-index ((ht indexed-btree) &key index-name key-form) + "Add a secondary index. The indices are stored in an eq +hash-table, so the index-name should be a symbol. key-form +should be a symbol naming a function, or a list which +defines a lambda -- actual functions aren't supported. The +function should take 3 arguments: the secondary DB, primary +key and value, and return two values: a boolean indicating +whether to index this key / value, and the secondary key if +so." + (if (and (not (null index-name)) + (symbolp index-name) (or (symbolp key-form) (listp key-form))) + (let ((indices (indices ht)) + (index (make-instance 'btree-index :primary ht + :key-form key-form))) + (setf (gethash index-name (indices-cache ht)) index) + (setf (gethash index-name indices) index) + (setf (indices ht) indices) + index) + (error "Invalid index initargs!"))) + +(defmethod get-index ((ht indexed-btree) index-name) + "Get a named index." + (gethash index-name (indices-cache ht))) + +(defmethod remove-index ((ht indexed-btree) index-name) + "Remove a named index." + (remhash index-name (indices-cache ht)) + (let ((indices (indices ht))) + (remhash index-name indices) + (setf (indices ht) indices))) + +(defmethod (setf get-value) (value key (ht indexed-btree)) + "Set a key / value pair, and update secondary indices." + (declare (optimize (speed 3))) + (let ((indices (indices-cache ht))) + (with-buffer-streams (key-buf value-buf secondary-buf) + (buffer-write-int (oid ht) 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 (ht 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 ht) key-buf) + (serialize key key-buf) + (with-transaction () + (let ((value (get-value key ht))) + (when value + (let ((indices (indices-cache ht))) + (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) + (reset-buffer-stream secondary-buf)))) + (db-delete-buffered (controller-btrees *store-controller*) + key-buf))))))) + +(defclass btree-index (btree) + ((primary :type indexed-btree :reader primary :initarg :primary) + (key-form :reader key-form :initarg :key-form) + (key-fn :type function :accessor key-fn :transient t)) + (:metaclass persistent-metaclass) + (:documentation "Secondary index to an indexed-btree.")) + +(defmethod shared-initialize :after ((instance btree-index) slot-names + &rest rest) + (declare (ignore slot-names rest)) + (let ((key-form (key-form instance))) + (if (and (symbolp key-form) (fboundp key-form)) + (setf (key-fn instance) (fdefinition key-form)) + (setf (key-fn instance) (compile nil key-form))))) + +(defmethod get-value (key (ht 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 ht) key-buf) + (serialize key key-buf) + (let ((buf (db-get-key-buffered + (controller-indices-assoc *store-controller*) + key-buf value-buf))) + (if buf (values (deserialize buf) T) + (values nil nil))))) + +(defmethod (setf get-value) (value key (ht btree-index)) + "Puts are not allowed on secondary indices. Try adding to +the primary." + (declare (ignore value key ht)) + (error "Puts are forbidden on secondary indices. Try adding to the primary.")) + +(defgeneric get-primary-key (key ht)) + +(defmethod get-primary-key (key (ht btree-index)) + "Get the primary key from a secondary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (let ((buf (db-get-key-buffered + (controller-indices *store-controller*) + key-buf value-buf))) + (if buf + (let ((oid (buffer-read-fixnum buf))) + (values (deserialize buf) oid)) + (values nil nil))))) + +(defmethod remove-kv (key (ht btree-index)) + "Remove a key / value, updating ALL secondary indices." + (declare (optimize (speed 3))) + (remove-kv (get-primary-key key ht) (primary ht))) + + +;; Cursor operations + +(defclass cursor () + ((handle :accessor cursor-handle :initarg :handle) + (oid :accessor cursor-oid :type fixnum :initarg :oid) + (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.")) + +(defgeneric make-cursor (ht)) +(defgeneric cursor-close (cursor)) +(defgeneric cursor-duplicate (cursor)) +(defgeneric cursor-current (cursor)) +(defgeneric cursor-first (cursor)) +(defgeneric cursor-last (cursor)) +(defgeneric cursor-next (cursor)) +(defgeneric cursor-prev (cursor)) +(defgeneric cursor-set (cursor key)) +(defgeneric cursor-set-range (cursor key)) +(defgeneric cursor-get-both (cursor key value)) +(defgeneric cursor-get-both-range (cursor key value)) +(defgeneric cursor-delete (cursor)) +(defgeneric cursor-put (cursor value &key key)) + +(defmethod make-cursor ((ht btree)) + "Construct a cursor for traversing primary BTrees." + (declare (optimize (speed 3))) + (make-instance 'cursor + :btree ht + :handle (db-cursor (controller-btrees *store-controller*)) + :oid (oid ht))) + +(defmacro with-btree-cursor ((var ht) &body body) + "Macro which opens a named cursor on a BTree (primary or +not), evaluates the forms, then closes the cursor." + `(let ((,var (make-cursor ,ht))) + (unwind-protect + (progn , at body) + (cursor-close ,var)))) + +(defun map-btree (fn bt) + "Like maphash." + (with-btree-cursor (curs bt) + (loop + (multiple-value-bind (more k v) (cursor-next curs) + (unless more (return nil)) + (funcall fn k v))))) + +(defmethod cursor-close ((cursor cursor)) + "Close the cursor. Make sure to close cursors before the +enclosing transaction is closed!" + (declare (optimize (speed 3))) + (db-cursor-close (cursor-handle cursor)) + (setf (cursor-initialized-p cursor) nil)) + +(defmethod cursor-duplicate ((cursor cursor)) + "Duplicate a cursor." + (declare (optimize (speed 3))) + (make-instance (type-of cursor) + :initialized-p (cursor-initialized-p cursor) + :oid (cursor-oid cursor) + :handle (db-cursor-duplicate + (cursor-handle cursor) + :position (cursor-initialized-p cursor)))) + +(defmethod cursor-current ((cursor cursor)) + "Get the key / value at the cursor position. Returns +has-pair key value, where has-pair is a boolean indicating +there was a pair." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf + :current t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-first ((cursor cursor)) + "Move the cursor to the beginning of the BTree, returning +has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (multiple-value-bind (key val) + (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil))))) + +;;A bit of a hack..... +(defmethod cursor-last ((cursor cursor)) + "Move the cursor to the end of the BTree, returning +has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) + (if (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (progn (reset-buffer-stream key-buf) + (reset-buffer-stream value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil)))) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf + value-buf :last t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-next ((cursor cursor)) + "Advance the cursor, returning has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-first cursor))) + +(defmethod cursor-prev ((cursor cursor)) + "Move the cursor back, returning has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-last cursor))) + +(defmethod cursor-set ((cursor cursor) key) + "Move the cursor to a particular key, returning has-pair +key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k val) + (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set t) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-set-range ((cursor cursor) key) + "Move the cursor to the first key-value pair with key +greater or equal to the key argument, according to the lisp +sorter. Returns has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k val) + (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (if (and k (= (buffer-read-int k) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize k) (deserialize val))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-get-both ((cursor cursor) key value) + "Moves the cursor to a particular key / value pair, +returning has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (multiple-value-bind (k v) + (db-cursor-get-both-buffered (cursor-handle cursor) + key-buf value-buf :get-both t) + (declare (ignore v)) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key value)) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-get-both-range ((cursor cursor) key value) + "Moves the cursor to the first key / value pair with key +equal to the key argument and value greater or equal to the +value argument. Not really useful for us since primaries +don't have duplicates. Returns has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (multiple-value-bind (k v) + (db-cursor-get-both-buffered (cursor-handle cursor) + key-buf value-buf :get-both-range t) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize v))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-delete ((cursor cursor)) + "Delete by cursor. The cursor is at an invalid position +after a successful delete." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf + :current t) + (declare (ignore val)) + (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))) + (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)) + "Put by cursor. Not particularly useful since primaries +don't support duplicates. Currently doesn't properly move +the cursor." + (declare (optimize (speed 3))) + (if key-specified-p + (setf (get-value key (cursor-btree cursor)) value) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (k v) + (db-cursor-move-buffered (cursor-handle cursor) key-buf + 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)) + value) + (setf (cursor-initialized-p cursor) nil)))) + (error "Can't put with uninitialized cursor!")))) + +;; Secondary cursors + +(defclass secondary-cursor (cursor) () + (:documentation "Cursor for traversing secondary indices.")) + +(defgeneric cursor-pcurrent (cursor)) +(defgeneric cursor-pfirst (cursor)) +(defgeneric cursor-plast (cursor)) +(defgeneric cursor-pnext (cursor)) +(defgeneric cursor-pprev (cursor)) +(defgeneric cursor-pset (cursor key)) +(defgeneric cursor-pset-range (cursor key)) +(defgeneric cursor-pget-both (cursor key value)) +(defgeneric cursor-pget-both-range (cursor key value)) +(defgeneric cursor-next-dup (cursor)) +(defgeneric cursor-next-nodup (cursor)) +(defgeneric cursor-prev-nodup (cursor)) +(defgeneric cursor-pnext-dup (cursor)) +(defgeneric cursor-pnext-nodup (cursor)) +(defgeneric cursor-pprev-nodup (cursor)) + +(defmethod make-cursor ((ht btree-index)) + "Make a secondary-cursor from a secondary index." + (declare (optimize (speed 3))) + (make-instance 'secondary-cursor + :btree ht + :handle (db-cursor + (controller-indices-assoc *store-controller*)) + :oid (oid ht))) + +(defmethod cursor-pcurrent ((cursor secondary-cursor)) + "Returns has-tuple / secondary key / value / primary key +at the current position." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf + :current t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pfirst ((cursor secondary-cursor)) + "Moves the key to the beginning of the secondary index. +Returns has-tuple / secondary key / value / primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pset-buffered (cursor-handle cursor) + 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) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil))))) + +;;A bit of a hack..... +(defmethod cursor-plast ((cursor secondary-cursor)) + "Moves the key to the end of the secondary index. Returns +has-tuple / secondary key / value / primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) + (if (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (progn (reset-buffer-stream key-buf) + (reset-buffer-stream value-buf) + (multiple-value-bind (key pkey val) + (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))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) + (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil)))) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) key-buf + pkey-buf value-buf :last t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pnext ((cursor secondary-cursor)) + "Advances the cursor. Returns has-tuple / secondary key / +value / primary key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (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) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-pfirst cursor))) + +(defmethod cursor-pprev ((cursor secondary-cursor)) + "Moves the cursor back. Returns has-tuple / secondary key +/ value / primary key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (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) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-plast cursor))) + +(defmethod cursor-pset ((cursor secondary-cursor) key) + "Moves the cursor to a particular key. Returns has-tuple +/ secondary key / value / primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k pkey val) + (db-cursor-pset-buffered (cursor-handle cursor) + 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)))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-pset-range ((cursor secondary-cursor) key) + "Move the cursor to the first key-value pair with key +greater or equal to the key argument, according to the lisp +sorter. Returns has-pair secondary key value primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k pkey val) + (db-cursor-pset-buffered (cursor-handle cursor) + 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)))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-pget-both ((cursor secondary-cursor) key pkey) + "Moves the cursor to a particular secondary key / primary +key pair. Returns has-tuple / secondary key / value / +primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (let ((primary-oid (oid (primary (cursor-btree cursor))))) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (buffer-write-int primary-oid pkey-buf) + (serialize pkey pkey-buf) + (multiple-value-bind (k p val) + (db-cursor-pget-both-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :get-both t) + (declare (ignore p)) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val) pkey)) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pget-both-range ((cursor secondary-cursor) key pkey) + "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." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (let ((primary-oid (oid (primary (cursor-btree cursor))))) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (buffer-write-int primary-oid pkey-buf) + (serialize pkey pkey-buf) + (multiple-value-bind (k p val) + (db-cursor-pget-both-buffered (cursor-handle cursor) key-buf + 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)))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-delete ((cursor secondary-cursor)) + "Delete by cursor: deletes ALL secondary indices." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf + value-buf :current t) + (declare (ignore val)) + (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)))) + (setf (cursor-initialized-p cursor) nil))) + (error "Can't delete with uninitialized cursor!"))) + +(defmethod cursor-get-both ((cursor 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) + "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) + "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)) + "Move to the next duplicate element (with the same key.) +Returns has-pair key value." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next-dup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-next-nodup ((cursor secondary-cursor)) + "Move to the next non-duplicate element (with different +key.) Returns has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next-nodup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-first cursor))) + +(defmethod cursor-prev-nodup ((cursor secondary-cursor)) + "Move to the previous non-duplicate element (with +different key.) Returns has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev-nodup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-last cursor))) + +(defmethod cursor-pnext-dup ((cursor secondary-cursor)) + "Move to the next duplicate element (with the same key.) +Returns has-tuple / secondary key / value / primary key." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (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) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pnext-nodup ((cursor secondary-cursor)) + "Move to the next non-duplicate element (with different +key.) Returns has-tuple / secondary key / value / primary +key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (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))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-pfirst cursor))) + +(defmethod cursor-pprev-nodup ((cursor secondary-cursor)) + "Move to the previous non-duplicate element (with +different key.) Returns has-tuple / secondary key / value / +primary key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (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))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-plast cursor))) + From blee at common-lisp.net Thu Sep 16 04:15:33 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:15:33 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25325/src Modified Files: controller.lisp Log Message: doc-strings table-layout for btrees better with-open-store macro Date: Thu Sep 16 06:15:32 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.9 elephant/src/controller.lisp:1.10 --- elephant/src/controller.lisp:1.9 Sat Sep 4 10:28:44 2004 +++ elephant/src/controller.lisp Thu Sep 16 06:15:31 2004 @@ -49,12 +49,16 @@ (environment :type (or null pointer-void) :accessor controller-environment) (db :type (or null pointer-void) :accessor controller-db) + (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 handling -the book-keeping of holding DB handles, the cache, table -creation, counters, locks, the root and garbage collection, + (: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.")) (defgeneric cache-instance (sc obj)) @@ -65,26 +69,24 @@ (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. Keys may be arbitrary -persistables as well (though note collection key semantics!) -N.B. this means it (and everything it points to) won't get -gc'd." +retrieve it in a later session. N.B. this means it (and +everything it points to) won't get gc'd." (setf (get-value key (controller-root store-controller)) value)) -(defmethod get-from-root (key &key (store-controller *store-controller*)) - "Get a persistent thing from the root." +(defun get-from-root (key &key (store-controller *store-controller*)) + "Get a something from the root." (get-value key (controller-root store-controller))) -(defmethod remove-from-root (key &key (store-controller *store-controller*)) - "Get a persistent thing from the root." +(defun remove-from-root (key &key (store-controller *store-controller*)) + "Remove something from the root." (remove-kv key (controller-root store-controller))) (defmethod cache-instance ((sc store-controller) obj) - "Register an instance of a user persistent-class with the -controller." + "Cache a persistent object with the controller." (setf (get-cache (oid obj) (instance-cache sc)) obj)) (defmethod get-cached-instance ((sc store-controller) oid class-name) + "Get a cached instance, or instantiate!" (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance @@ -111,6 +113,7 @@ (defvar %oid-lock-length 16) (defmethod next-oid ((sc store-controller)) + "Get the next OID." (sleepycat::next-counter (controller-environment sc) (controller-db sc) *current-transaction* @@ -128,19 +131,46 @@ (db-env-open env (controller-path sc) :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread thread :recover recover :recover-fatal recover-fatal) - (let ((db (db-create env))) + (let ((db (db-create env)) + (btrees (db-create env)) + (indices (db-create env)) + (indices-assoc (db-create env))) (setf (controller-db sc) db) (db-open db :file "%ELEPHANT" :database "%ELEPHANTDB" :auto-commit t :type DB-BTREE :create t :thread thread) + + (setf (controller-btrees sc) btrees) + (sleepycat::db-set-lisp-compare btrees) + (db-open btrees :file "%ELEPHANT" :database "%ELEPHANTBTREES" + :auto-commit t :type DB-BTREE :create t :thread thread) + + (setf (controller-indices sc) indices) + (sleepycat::db-set-lisp-compare indices) + (sleepycat::db-set-lisp-dup-compare indices) + (db-set-flags indices :dup-sort t) + (db-open indices :file "%ELEPHANT" :database "%ELEPHANTINDICES" + :auto-commit t :type DB-BTREE :create t :thread thread) + + (setf (controller-indices-assoc sc) indices-assoc) + (sleepycat::db-set-lisp-compare indices-assoc) + (sleepycat::db-set-lisp-dup-compare indices-assoc) + (db-set-flags indices-assoc :dup-sort t) + (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES" + :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t) + (sleepycat::db-fake-associate btrees indices-assoc :auto-commit t) + (let ((root (make-instance 'btree :from-oid -1))) (setf (slot-value sc 'root) root) - (let ((*auto-commit* t)) - (unless (db-get-key-buffered db %oid-entry %oid-entry-length) - (buffer-write-int 0 *out-buf*) - (db-put-buffered db %oid-entry %oid-entry-length - (buffer-stream-buffer *out-buf*) 4 - :auto-commit t) - (finish-buffer *out-buf*))) + (with-transaction () + (with-buffer-streams (key-buf value-buf) + (let ((key-b (buffer-stream-buffer key-buf))) + (setf (buffer-stream-buffer key-buf) %oid-entry) + (setf (sleepycat::buffer-stream-size key-buf) %oid-entry-length) + (unless (db-get-key-buffered db key-buf value-buf) + (reset-buffer-stream value-buf) + (buffer-write-int 0 value-buf) + (db-put-buffered db key-buf value-buf)) + (setf (buffer-stream-buffer key-buf) key-b)))) sc)))) (defmethod close-controller ((sc store-controller)) @@ -151,7 +181,13 @@ (setf (slot-value sc 'root) nil) ;; clean instance cache (setf (instance-cache sc) (make-cache-table :test 'eql)) - ;; close environment + ;; close handles / environment + (db-close (controller-indices-assoc sc)) + (setf (controller-indices-assoc sc) nil) + (db-close (controller-indices sc)) + (setf (controller-indices sc) nil) + (db-close (controller-btrees sc)) + (setf (controller-btrees sc) nil) (db-close (controller-db sc)) (setf (controller-db sc) nil) (db-env-close (controller-environment sc)) @@ -160,6 +196,8 @@ (defmacro with-open-controller ((&optional (sc '*store-controller*)) &body body) + "Executes body with the specified controller open, closing +the controller unconditionally on exit." `(unwind-protect (progn (let (*store-controller* (open-controller ,sc)) @@ -167,21 +205,24 @@ , at body)) (close-controller ,sc))) -(defun open-store (path) +(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*)) + (open-controller *store-controller* :recover recover + :recover-fatal recover-fatal :thread thread)) (defun close-store () + "Conveniently close the store controller." (close-controller *store-controller*)) (defmacro with-open-store ((path) &body body) - (let ((sc (gensym))) - `(let ((,sc (make-instance 'store-controller :path ,path))) - (unwind-protect - (progn - (let ((*store-controller* ,sc)) - (declare (special *store-controller*)) - (open-controller *store-controller*) - , at body)) - (close-controller ,sc))))) + "Executes the body with an open controller, +unconditionally closing the controller on exit." + `(let ((*store-controller* (make-instance 'store-controller :path ,path))) + (declare (special *store-controller*)) + (open-controller *store-controller*) + (unwind-protect + (progn , at body) + (close-controller *store-controller*)))) From blee at common-lisp.net Thu Sep 16 04:16:15 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:16:15 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25620/src Modified Files: elephant.lisp Log Message: doc-strings slot-makunbound-using-class Date: Thu Sep 16 06:16:15 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.10 elephant/src/elephant.lisp:1.11 --- elephant/src/elephant.lisp:1.10 Sat Sep 4 10:17:24 2004 +++ elephant/src/elephant.lisp Thu Sep 16 06:16:14 2004 @@ -41,16 +41,39 @@ ;;; (defpackage elephant + (:documentation + "Elephant: an object-oriented database for Common Lisp. +Uses the SLEEPYCAT package to talk to Berkeley DB / +Sleepycat.") (:nicknames ele :ele) - (:use common-lisp sleepycat) + (:use common-lisp sleepycat uffi) (:shadow #:with-transaction) (:export #:*store-controller* #:*current-transaction* #:*auto-commit* #: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 + #:persistent #:persistent-object #:persistent-metaclass + #:persistent-collection #:btree #:get-value #:remove-kv + #:indexed-btree #:add-index #:get-index #:remove-index + #:btree-index #:get-primary-key + #:indices #:primary #:key-form #:key-fn + + #:cursor #:secondary-cursor #:make-cursor + #:with-btree-cursor #:map-btree #:cursor-close + #:cursor-duplicate #:cursor-current #:cursor-first + #:cursor-last #:cursor-next #:cursor-next-dup + #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup + #:cursor-set #:cursor-set-range #:cursor-get-both + #:cursor-get-both-range #:cursor-delete #:cursor-put + #:cursor-pcurrent #:cursor-pfirst #:cursor-plast + #:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup + #:cursor-pprev #:cursor-pprev-nodup #:cursor-pset + #:cursor-pset-range #:cursor-pget-both + #:cursor-pget-both-range + #:db-transaction-begin #:db-transaction-abort #:db-transaction-commit #:with-transaction #:db-env-set-lock-detect #:db-env-get-lock-detect @@ -76,6 +99,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots @@ -113,6 +137,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots) @@ -151,6 +176,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots) @@ -173,6 +199,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots @@ -203,10 +230,15 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots) ) -(in-package "ELE") \ No newline at end of file +(in-package "ELE") + +#+cmu +(eval-when (:compile-toplevel) + (proclaim '(optimize (ext:inhibit-warnings 3)))) \ No newline at end of file From blee at common-lisp.net Thu Sep 16 04:18:28 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:18:28 +0200 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25807/src Modified Files: libsleepycat.c Log Message: need to memcpy on writers (alignment) lisp-cmp func, assoc / btree cmp stuff cursor pget, remove key value using cursor length->size Date: Thu Sep 16 06:18:27 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.7 elephant/src/libsleepycat.c:1.8 --- elephant/src/libsleepycat.c:1.7 Thu Sep 2 16:45:53 2004 +++ elephant/src/libsleepycat.c Thu Sep 16 06:18:27 2004 @@ -39,40 +39,48 @@ ;;; to the Free Software Foundation, Inc., 59 Temple Place, ;;; Suite 330, Boston, MA 02111-1307 USA ;;; -8? +*/ /* Pointer arithmetic utility functions */ - +/* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { - return *(int*)(buf + offset); + int i; + memcpy(&i, buf+offset, sizeof(int)); + return i; } unsigned int read_uint(char *buf, int offset) { - return *(unsigned int*)(buf + offset); + unsigned int ui; + memcpy(&ui, buf+offset, sizeof(unsigned int)); + return ui; } float read_float(char *buf, int offset) { - return *(float*)(buf + offset); + float f; + memcpy(&f, buf+offset, sizeof(float)); + return f; } double read_double(char *buf, int offset) { - return *(double*)(buf + offset); + double d; + memcpy(&d, buf+offset, sizeof(double)); + return d; } void write_int(char *buf, int num, int offset) { - *(int*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(int)); } void write_uint(char *buf, unsigned int num, int offset) { - *(unsigned int*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(unsigned int)); } void write_float(char *buf, float num, int offset) { - *(float*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(float)); } void write_double(char *buf, double num, int offset) { - *(double*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(double)); } char *offset_charp(char *p, int offset) { @@ -172,6 +180,14 @@ return db->truncate(db, txnid, countp, flags); } +int db_set_flags(DB *db, u_int32_t flags) { + return db->set_flags(db, flags); +} + +int db_get_flags(DB *db, u_int32_t *flagsp) { + return db->get_flags(db, flagsp); +} + int db_set_pagesize(DB *db, u_int32_t pagesize) { return db->set_pagesize(db, pagesize); } @@ -180,54 +196,303 @@ return db->get_pagesize(db, pagesizep); } +int db_set_bt_compare(DB *db, + int (*bt_compare_fcn)(DB *db, const DBT *dbt1, + const DBT *dbt2)) { + return db->set_bt_compare(db, bt_compare_fcn); +} + +int db_set_dup_compare(DB *db, + int (*dup_compare_fcn)(DB *db, const DBT *dbt1, + const DBT *dbt2)) { + return db->set_dup_compare(db, dup_compare_fcn); +} + +#define type_numeric(c) ((c)<8) +#include + +double read_num(char *buf); + +/* Inspired by the Sleepycat docs. We have to memcpy to + insure memory alignment. */ +int lisp_compare(DB *dbp, const DBT *a, const DBT *b) { + int difference; + double ddifference; + char *ad, *bd, at, bt; + ad = (char*)a->data; + bd = (char*)b->data; + + /* Compare OIDs. */ + difference = read_int(ad, 0) - read_int(bd, 0); + if (difference) return difference; + + /* Have a type tag? */ + if (a->size == 4) + if (b->size == 4) + return 0; + else + return -1; + else if (b->size == 4) + return 1; + + at = ad[4]; bt = bd[4]; + + /* Compare numerics. */ + if (type_numeric(at) && type_numeric(bt)) { + ddifference = read_num(ad+4) - read_num(bd+4); + if (ddifference > 0) return 1; + else if (ddifference < 0) return -1; + return 0; + } + + /* Compare types. */ + difference = at - bt; + if (difference) return difference; + + /* Same type! */ + switch (at) { + case 8: /* nil */ + return 0; + case 9: /* 8-bit symbol */ + case 10: /* 8-bit string */ + case 11: /* 8-bit pathname */ + return case_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); + case 12: /* 16-bit symbol */ + case 13: /* 16-bit string */ + case 14: /* 16-bit pathname */ + return utf16_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); + default: + return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); + } +} + +int db_set_lisp_compare(DB *db) { + return db->set_bt_compare(db, &lisp_compare); +} + +int db_set_lisp_dup_compare(DB *db) { + return db->set_dup_compare(db, &lisp_compare); +} + +#ifndef exp2 +#define exp2(c) (pow(2,(c))) +#endif + +double read_num(char *buf) { + char *limit; + double i, result, denom; + switch (buf[0]) { + case 1: + case 2: + return (double)read_int(buf, 1); + case 3: + return (double)read_float(buf, 1); + case 4: + return read_double(buf, 1); + case 5: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result -= exp2(i*32) * read_uint(buf, 0); + } + return result; + case 6: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result += exp2(i*32) * read_uint(buf, 0); + } + return result; + case 7: + switch ((++buf)[0]) { + case 1: + result = (double)read_int(++buf, 0); + buf += 4; + break; + case 5: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result -= exp2(i*32) - read_uint(buf, 0); + } + break; + case 6: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result += exp2(i*32) * read_uint(buf, 0); + } + break; + } + + switch (buf[0]) { + case 1: + return result / read_int(++buf, 0); + case 5: + denom = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + denom -= exp2(i*32) * read_uint(buf, 0); + } + return result / denom; + case 6: + denom = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + denom += exp2(i*32) * read_uint(buf, 0); + } + return result / denom; + } + } +} + +int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { + int min, sizediff, diff; + sizediff = length1 - length2; + min = sizediff > 0 ? length2 : length1; + diff = strncasecmp(a, b, min); + if (diff == 0) return sizediff; + return diff; +} + +int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { + int min, sizediff, diff; + sizediff = length1 - length2; + min = sizediff > 0 ? length2 : length1; + diff = memcmp(a, b, min); + if (diff == 0) return sizediff; + return diff; +} +/* The following is copied from + http://oss.software.ibm.com/cvs/icu/~checkout~/icu/source/common/ustring.c +*/ +typedef uint16_t UChar; + +#define UTF_IS_LEAD(c) (((c)&0xfffffc00)==0xd800) +#define UTF_IS_TRAIL(c) (((c)&0xfffffc00)==0xdc00) + +/* compare UTF-16 strings */ +/* memcmp/UnicodeString style, both length-specified */ +/* don't assume byte-aligned! */ +int utf16_cmp(const char *s1, int32_t length1, + const char *s2, int32_t length2) { + const char *start1, *start2, *limit1, *limit2; + UChar c1, c2; + int32_t lengthResult; + + if(length1length2 */ { + lengthResult=1; + limit1=s1+length2; + } + + if(s1==s2) return lengthResult; + + start1=s1; + start2=s2; + + for(;;) { + if(s1==limit1) return lengthResult; + + memcpy(&c1, s1, sizeof(UChar)); + memcpy(&c2, s2, sizeof(UChar)); + if(c1!=c2) break; + + s1 = s1 + 2; + s2 = s2 + 2; + } + + limit1=start1+length1; + limit2=start2+length2; + + if(c1>=0xd800 && c2>=0xd800) { + if(c1>=0xe000) + c1-=0x800; + else + c1+=0x2000; + + if(c2>=0xe000) + c2-=0x800; + else + c2+=0x2000; + + /* here's some newer code which i can't make work + if((c1<=0xdbff && (s1+1)!=limit1 && UTF_IS_TRAIL(*(s1+1))) || + (UTF_IS_TRAIL(c1) && start1!=s1 && UTF_IS_LEAD(*(s1-1)))) { + } else { + c1-=0x2800; + } + + if((c2<=0xdbff && (s2+1)!=limit2 && UTF_IS_TRAIL(*(s2+1))) || + (UTF_IS_TRAIL(c2) && start2!=s2 && UTF_IS_LEAD(*(s2-1)))) { + } else { + c2-=0x2800; + }*/ + } + + return (int32_t)c1-(int32_t)c2; +} + + /* Accessors */ /* We manage our own buffers (DB_DBT_USERMEM). */ int db_get_raw(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_length, + char *key, u_int32_t key_size, char *buffer, u_int32_t buffer_length, - u_int32_t flags, u_int32_t *result_length) { - DBT DBTKey, DBTDatum; + u_int32_t flags, u_int32_t *result_size) { + DBT DBTKey, DBTValue; int ret; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; - DBTDatum.data = buffer; - DBTDatum.ulen = buffer_length; - DBTDatum.flags |= DB_DBT_USERMEM; + DBTKey.size = key_size; + DBTValue.data = buffer; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; - ret = db->get(db, txnid, &DBTKey, &DBTDatum, flags); - *result_length = DBTDatum.size; + ret = db->get(db, txnid, &DBTKey, &DBTValue, flags); + *result_size = DBTValue.size; return ret; } int db_put_raw(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_length, - char *datum, u_int32_t datum_length, + char *key, u_int32_t key_size, + char *value, u_int32_t value_size, u_int32_t flags) { - DBT DBTKey, DBTDatum; + DBT DBTKey, DBTValue; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; - DBTDatum.data = datum; - DBTDatum.size = datum_length; + DBTKey.size = key_size; + DBTValue.data = value; + DBTValue.size = value_size; - return db->put(db, txnid, &DBTKey, &DBTDatum, flags); + return db->put(db, txnid, &DBTKey, &DBTValue, flags); } int db_del(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_length, + char *key, u_int32_t key_size, u_int32_t flags) { DBT DBTKey; memset(&DBTKey, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; + DBTKey.size = key_size; return db->del(db, txnid, &DBTKey, flags); } @@ -255,72 +520,148 @@ } int db_cursor_get_raw(DBC *cursor, - char *keybuf, u_int32_t keybuf_length, - char *buffer, u_int32_t buffer_length, - u_int32_t flags, u_int32_t *key_length, - u_int32_t *result_length) { - DBT DBTKey, DBTDatum; + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + char *buffer, u_int32_t buffer_size, + u_int32_t buffer_length, + u_int32_t flags, u_int32_t *ret_key_size, + u_int32_t *result_size) { + DBT DBTKey, DBTValue; + int ret; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); + DBTKey.data = keybuf; + DBTKey.size = keybuf_size; + DBTKey.ulen = keybuf_length; + DBTKey.flags |= DB_DBT_USERMEM; + DBTValue.data = buffer; + DBTValue.size = buffer_size; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; + + ret = cursor->c_get(cursor, &DBTKey, &DBTValue, flags); + *ret_key_size = DBTKey.size; + *result_size = DBTValue.size; + + return ret; +} + +int db_cursor_pget_raw(DBC *cursor, + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + char *pkeybuf, u_int32_t pkeybuf_size, + u_int32_t pkeybuf_length, + char *buffer, u_int32_t buffer_size, + u_int32_t buffer_length, + u_int32_t flags, + u_int32_t *ret_key_size, + u_int32_t *ret_pkey_size, + u_int32_t *result_size) { + DBT DBTKey, DBTPKey, DBTValue; int ret; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTPKey, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = keybuf; + DBTKey.size = keybuf_size; DBTKey.ulen = keybuf_length; DBTKey.flags |= DB_DBT_USERMEM; - DBTDatum.data = buffer; - DBTDatum.ulen = buffer_length; - DBTDatum.flags |= DB_DBT_USERMEM; - - ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags); - *key_length = DBTKey.size; - *result_length = DBTDatum.size; + DBTPKey.data = pkeybuf; + DBTPKey.size = pkeybuf_size; + DBTPKey.ulen = pkeybuf_length; + DBTPKey.flags |= DB_DBT_USERMEM; + DBTValue.data = buffer; + DBTValue.size = buffer_size; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; + + ret = cursor->c_pget(cursor, &DBTKey, &DBTPKey, &DBTValue, flags); + *ret_key_size = DBTKey.size; + *ret_pkey_size = DBTPKey.size; + *result_size = DBTValue.size; return ret; } int db_cursor_put_raw(DBC *cursor, - char *key, u_int32_t key_length, - char *datum, u_int32_t datum_length, + char *key, u_int32_t key_size, + char *value, u_int32_t value_size, u_int32_t flags) { - DBT DBTKey, DBTDatum; + DBT DBTKey, DBTValue; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; - DBTDatum.data = datum; - DBTDatum.size = datum_length; + DBTKey.size = key_size; + DBTValue.data = value; + DBTValue.size = value_size; - return cursor->c_put(cursor, &DBTKey, &DBTDatum, flags); + return cursor->c_put(cursor, &DBTKey, &DBTValue, flags); } +/* Silently does nothing if the key/value isn't found. + Can't use auto-commit here! */ +int db_del_kv(DB *db, DB_TXN *tid, + char *key, u_int32_t key_size, + char *value, u_int32_t value_size) { + DBT DBTKey, DBTValue; + DBC *cursor; + int ret, c_ret; + + memset(&DBTKey, 0, sizeof(DBT)); + DBTKey.data = key; + DBTKey.size = key_size; + memset(&DBTValue, 0, sizeof(DBT)); + DBTValue.data = value; + DBTValue.size = value_size; + + if ((ret = db->cursor(db, tid, &cursor, 0)) != 0) + return ret; + + if ((ret = cursor->c_get(cursor, &DBTKey, &DBTValue, DB_GET_BOTH)) != 0) + goto fail; + + ret = cursor->c_del(cursor, 0); + + fail: + if ((c_ret = cursor->c_close(cursor)) != 0) + return c_ret; + return ret; +} + /* Bulk retrieval */ int db_cursor_get_multiple_key(DBC *cursor, - char *keybuf, u_int32_t keybuf_length, - char *buffer, u_int32_t buffer_length, - u_int32_t flags, u_int32_t *key_length, - u_int32_t *result_length, + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + char *buffer, u_int32_t buffer_size, + u_int32_t buffer_length, + u_int32_t flags, u_int32_t *ret_key_size, + u_int32_t *result_size, void **pointer, DBT **data) { - DBT DBTKey, DBTDatum; + DBT DBTKey, DBTValue; int ret; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = keybuf; + DBTKey.size = keybuf_size; DBTKey.ulen = keybuf_length; DBTKey.flags |= DB_DBT_USERMEM; - DBTDatum.data = buffer; - DBTDatum.ulen = buffer_length; - DBTDatum.flags |= DB_DBT_USERMEM; + DBTValue.data = buffer; + DBTValue.size = buffer_size; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; flags |= DB_MULTIPLE_KEY; - ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags); - *key_length = DBTKey.size; - *result_length = DBTDatum.size; - if ((DBTKey.size <= DBTKey.ulen) && (DBTDatum.size <= DBTDatum.ulen)) { - **data = DBTDatum; + ret = cursor->c_get(cursor, &DBTKey, &DBTValue, flags); + *ret_key_size = DBTKey.size; + *result_size = DBTValue.size; + if ((DBTKey.size <= DBTKey.ulen) && (DBTValue.size <= DBTValue.ulen)) { + **data = DBTValue; DB_MULTIPLE_INIT(*pointer, *data); } @@ -328,11 +669,11 @@ } void db_multiple_key_next(void *pointer, DBT *data, - char **key, u_int32_t *key_length, - char **result, u_int32_t *result_length) { + char **key, u_int32_t *ret_key_size, + char **result, u_int32_t *result_size) { DB_MULTIPLE_KEY_NEXT(pointer, data, - *key, *key_length, - *result, *result_length); + *key, *ret_key_size, + *result, *result_size); } /* Transactions */ @@ -373,12 +714,12 @@ } int db_env_lock_get(DB_ENV *env, u_int32_t locker, - u_int32_t flags, char *object, u_int32_t object_length, + u_int32_t flags, char *object, u_int32_t object_size, const db_lockmode_t lock_mode, DB_LOCK *lock) { DBT DBTObject; memset(&DBTObject, 0, sizeof(DBT)); DBTObject.data = object; - DBTObject.size = object_length; + DBTObject.size = object_size; return env->lock_get(env, locker, flags, &DBTObject, lock_mode, lock); } @@ -414,11 +755,28 @@ return env->lock_detect(env, flags, atype, aborted); } +/* Secondary indices */ + +int db_associate(DB *primary, DB_TXN *txnid, DB *secondary, + int (*callback)(DB *, const DBT *, const DBT *, DBT *), + u_int32_t flags) { + return primary->associate(primary, txnid, secondary, callback, flags); +} + +int never_index(DB *db, const DBT *key, const DBT *data, DBT *result) { + return DB_DONOTINDEX; +} + +int db_fake_associate(DB *primary, DB_TXN *txnid, DB *secondary, + u_int32_t flags) { + return primary->associate(primary, txnid, secondary, &never_index, flags); +} + /* Poor man's counters */ int next_counter(DB_ENV *env, DB *db, DB_TXN *parent, - char *key, u_int32_t key_length, - char *lockid, u_int32_t lockid_length) { + char *key, u_int32_t key_size, + char *lockid, u_int32_t lockid_size) { DB_LOCK lock; DBT DBTKey, DBTData; DB_TXN *tid; @@ -430,9 +788,9 @@ memset(&DBTKey, 0, sizeof(DBTKey)); memset(&DBTData, 0, sizeof(DBTData)); DBTKey.data = key; - DBTKey.size = key_length; + DBTKey.size = key_size; DBTData.data = lockid; - DBTData.size = lockid_length; + DBTData.size = lockid_size; tries = 0; From blee at common-lisp.net Thu Sep 16 04:19:13 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:19:13 +0200 Subject: [elephant-cvs] CVS update: elephant/src/metaclasses.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25836/src Modified Files: metaclasses.lisp Log Message: docstrings changeover to buffer-streams Date: Thu Sep 16 06:19:12 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.4 elephant/src/metaclasses.lisp:1.5 --- elephant/src/metaclasses.lisp:1.4 Thu Sep 2 09:15:48 2004 +++ elephant/src/metaclasses.lisp Thu Sep 16 06:19:12 2004 @@ -49,7 +49,8 @@ to user-defined classes and collections.)")) (defclass persistent-metaclass (standard-class) - ()) + () + (:documentation "Metaclass for persistent classes.")) (defclass persistent-slot-definition (standard-slot-definition) ()) @@ -81,6 +82,8 @@ :class) (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) + "Checks for the transient tag (and the allocation type) +and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient))) (when (consp transient-p) (setq transient-p (car transient-p))) @@ -94,9 +97,11 @@ (find-class 'persistent-direct-slot-definition))))) (defmethod validate-superclass ((class persistent-metaclass) (super standard-class)) + "Persistent classes may inherit from ordinary classes." t) (defmethod validate-superclass ((class standard-class) (super persistent-metaclass)) + "Ordinary classes may NOT inherit from persistent classes." nil) (defgeneric persistent-p (class)) @@ -111,6 +116,8 @@ t) (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) + "Chooses the persistent or transient effective slot +definition class depending on the keyword." (let ((transient-p (getf initargs :transient))) (when (consp transient-p) (setq transient-p (car transient-p))) (cond (transient-p @@ -193,17 +200,17 @@ (defmacro persistent-slot-reader (instance name) `(progn - (buffer-write-int (oid ,instance) *key-buf*) - (let* ((key-length (serialize ,name *key-buf*)) - (buf (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length))) - (if buf (deserialize buf) - #+cmu - (error 'unbound-slot :instance ,instance :slot ,name) - #-cmu - (error 'unbound-slot :instance ,instance :name ,name))))) + (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)))))) #+(or cmu sbcl) (defun make-persistent-reader (name) @@ -214,14 +221,14 @@ (defmacro persistent-slot-writer (new-value instance name) `(progn - (buffer-write-int (oid ,instance) *key-buf*) - (let ((key-length (serialize ,name *key-buf*)) - (val-length (serialize ,new-value *out-buf*))) + (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*) - (buffer-stream-buffer *key-buf*) key-length - (buffer-stream-buffer *out-buf*) val-length - :transaction *current-transaction* - :auto-commit *auto-commit*) + key-buf value-buf + :transaction *current-transaction* + :auto-commit *auto-commit*) ,new-value))) #+(or cmu sbcl) @@ -233,13 +240,13 @@ (defmacro persistent-slot-boundp (instance name) `(progn - (buffer-write-int (oid ,instance) *key-buf*) - (let* ((key-length (serialize ,name *key-buf*)) - (buf (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length))) - (if buf T nil)))) + (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))))) #+(or cmu sbcl) (defun make-persistent-slot-boundp (name) From blee at common-lisp.net Thu Sep 16 04:19:57 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:19:57 +0200 Subject: [elephant-cvs] CVS update: elephant/src/berkeley-db.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25863/src Added Files: berkeley-db.lisp Log Message: split from sleepycat.lisp doc-strings buffer-streamified Date: Thu Sep 16 06:19:57 2004 Author: blee From blee at common-lisp.net Thu Sep 16 04:20:42 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:20:42 +0200 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25896/src Modified Files: serializer.lisp Log Message: doc-strings buffer-streamified sanified type tags Date: Thu Sep 16 06:20:42 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.8 elephant/src/serializer.lisp:1.9 --- elephant/src/serializer.lisp:1.8 Sat Sep 4 10:59:40 2004 +++ elephant/src/serializer.lisp Thu Sep 16 06:20:41 2004 @@ -51,30 +51,46 @@ ;; Constants -(defconstant +fixnum+ (char-code #\f)) -(defconstant +nil+ (char-code #\N)) -(defconstant +symbol+ (char-code #\S)) -(defconstant +string+ (char-code #\s)) -(defconstant +persistent+ (char-code #\P)) -(defconstant +single-float+ (char-code #\F)) -(defconstant +double-float+ (char-code #\D)) -(defconstant +char+ (char-code #\c)) -(defconstant +pathname+ (char-code #\p)) -(defconstant +positive-bignum+ (char-code #\B)) -(defconstant +negative-bignum+ (char-code #\b)) -(defconstant +rational+ (char-code #\r)) -(defconstant +cons+ (char-code #\C)) -(defconstant +hash-table+ (char-code #\H)) -(defconstant +object+ (char-code #\O)) +(defconstant +fixnum+ 1) +(defconstant +char+ 2) +(defconstant +single-float+ 3) +(defconstant +double-float+ 4) +(defconstant +negative-bignum+ 5) +(defconstant +positive-bignum+ 6) +(defconstant +rational+ 7) + +(defconstant +nil+ 8) + +;; 8-bit +#-(or lispworks (and allegro ics)) +(defconstant +symbol+ 9) +#-(or lispworks (and allegro ics)) +(defconstant +string+ 10) +#-(or lispworks (and allegro ics)) +(defconstant +pathname+ 11) + +;; 16-bit +#+(or lispworks (and allegro ics)) +(defconstant +symbol+ 12) +#+(or lispworks (and allegro ics)) +(defconstant +string+ 13) +#+(or lispworks (and allegro ics)) +(defconstant +pathname+ 14) + +(defconstant +persistent+ 15) +(defconstant +cons+ 16) +(defconstant +hash-table+ 17) +(defconstant +object+ 18) +(defconstant +array+ 19) -(defconstant +array+ (char-code #\A)) - -(defconstant +fill-pointer-p+ #x40) -(defconstant +adjustable-p+ #x80) +(defconstant +fill-pointer-p+ #x40) +(defconstant +adjustable-p+ #x80) (defun serialize (frob bs) - (declare (optimize (speed 3) (safety 0))) + "Serialize a lisp value into a buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) (setq *lisp-obj-id* 0) (clrhash *circularity-hash*) (labels @@ -207,7 +223,7 @@ (%serialize (row-major-aref frob i))))))) ))) (%serialize frob) - (finish-buffer bs))) + bs)) (defun slots-and-values (o) (declare (optimize (speed 3) (safety 0))) @@ -222,14 +238,10 @@ (push slot-name ret)) finally (return ret))) -(defun deserialize (buf) +(defun deserialize (buf-str) + "Deserialize a lisp value from a buffer-stream." (declare (optimize (speed 3) (safety 0)) - (type (or null array-or-pointer-char) buf)) - (unless buf (return-from deserialize nil)) - (setf (buffer-stream-buffer *in-buf*) buf) - (setf (buffer-stream-position *in-buf*) 0) - (setq *lisp-obj-id* 0) - (clrhash *circularity-hash*) + (type (or null buffer-stream) buf-str)) (labels ((%deserialize (bs) (declare (optimize (speed 3) (safety 0)) @@ -325,7 +337,12 @@ (setf (row-major-aref a i) (%deserialize bs))) a)))) (t (error "deserialize fubar!")))))) - (%deserialize *in-buf*))) + (etypecase buf-str + (null (return-from deserialize nil)) + (buffer-stream + (setq *lisp-obj-id* 0) + (clrhash *circularity-hash*) + (%deserialize buf-str))))) (defun deserialize-bignum (bs length positive) (declare (optimize (speed 3) (safety 0)) @@ -387,9 +404,9 @@ (defun int-byte-spec (position) (declare (optimize (speed 3) (safety 0)) (type (unsigned-byte 24) position)) - #+(or cmu scl sbcl allegro) + #+(or cmu sbcl allegro) (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) *resourced-byte-spec*) - #-(or cmu scl sbcl allegro) + #-(or cmu sbcl allegro) (byte 32 (* 32 position)) ) From blee at common-lisp.net Thu Sep 16 04:23:50 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:23:50 +0200 Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv26060/src Modified Files: utils.lisp Log Message: doc-strings buffer-streams to sleepycat.lisp with-transaction defaults to *auto-commit* nil Date: Thu Sep 16 06:23:50 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.5 elephant/src/utils.lisp:1.6 --- elephant/src/utils.lisp:1.5 Sat Sep 4 10:23:30 2004 +++ elephant/src/utils.lisp Thu Sep 16 06:23:49 2004 @@ -42,76 +42,53 @@ (in-package "ELEPHANT") -(eval-when (:compile-toplevel :load-toplevel :execute) - (use-package "UFFI")) -(declaim (inline ;resize-buffer-stream - finish-buffer - buffer-write-byte buffer-write-int buffer-write-uint - buffer-write-float buffer-write-double buffer-write-string - buffer-read-byte buffer-read-fixnum buffer-read-int - buffer-read-uint buffer-read-float buffer-read-double - buffer-read-string) - (type fixnum *lisp-obj-id*) +(declaim (type fixnum *lisp-obj-id*) (type hash-table *circularity-hash*) (type boolean *auto-commit*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; buffer-streams -;;; -;;; a stream-like interface for our buffers; methods are -;;; below. ultimately we might want a gray / simple -stream -;;; for real, for now who cares? - -(defstruct buffer-stream - (buffer (allocate-foreign-object :char 1) :type array-or-pointer-char) - (length 0 :type fixnum) - (position 0 :type fixnum)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Thread-local specials (defparameter *store-controller* nil "The store controller which persistent objects talk to.") ;; Specials which control persistent objects -(defvar *auto-commit* T) - -(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*)) - -;; Buffers for going in and out of the DB -(defvar *out-buf* (make-buffer-stream)) -(defvar *key-buf* (make-buffer-stream)) -(defvar *in-buf* (make-buffer-stream)) +(defvar *auto-commit* T + "Commit things not in transactions?") ;; Stuff the serializer uses -(defvar *lisp-obj-id* 0) -(defvar *circularity-hash* (make-hash-table :test 'eq)) -#+(or cmu scl sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0)) +(defvar *lisp-obj-id* 0 + "Circularity ids for the serializer.") +(defvar *circularity-hash* (make-hash-table :test 'eq) + "Circularity hash for the serializer.") + +#+(or cmu sbcl allegro) +(defvar *resourced-byte-spec* (byte 32 0) + "Byte specs on CMUCL, SBCL and Allegro are conses.") ;; TODO: make this for real! (defun run-elephant-thread (thunk) + "Sets the specials (which hopefully are thread-local) to +make the Elephant thread-safe." (let ((*current-transaction* +NULL-VOID+) - (*errno-buffer* (allocate-foreign-object :int 1)) - (*get-buffer* (allocate-foreign-object :char 1)) - (*get-buffer-length* 0) + (sleepycat::*errno-buffer* (allocate-foreign-object :int 1)) + ;; if vector-push-extend et al are thread-safe, this + ;; doesn't need to be thread-local. + (sleepycat::*buffer-streams* + (make-array 0 :adjustable t :fill-pointer t)) (*store-controller* *store-controller*) (*auto-commit* *auto-commit*) - (*out-buf* (make-buffer-stream)) - (*key-buf* (make-buffer-stream)) - (*in-buf* (make-buffer-stream)) (*lisp-obj-id* 0) (*circularity-hash* (make-hash-table :test 'eq)) - #+(or cmu scl sbcl allegro) + #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0))) - (declare (special *current-transaction* *errno-buffer* - *get-buffer* *get-buffer-length* *store-controller* - *auto-commit* *out-buf* *key-buf* *in-buf* + (declare (special *current-transaction* sleepycat::*errno-buffer* + sleepycat::*buffer-streams* + *store-controller* *auto-commit* *lisp-obj-id* *circularity-hash* - #+(or cmu scl sbcl allegro) *resourced-byte-spec*)) + #+(or cmu sbcl allegro) *resourced-byte-spec*)) (funcall thunk))) @@ -128,6 +105,11 @@ 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 @@ -136,7 +118,8 @@ :txn-nowait ,txn-nowait :txn-sync ,txn-sync :retries ,retries) - , at body)) + (let ((*auto-commit* nil)) + , at body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -146,242 +129,70 @@ ;;; flushed from the table too (defun make-cache-table (&rest args) + "Make a values-weak hash table: when a value has been +collected, so are the keys." #+(or cmu sbcl scl) (apply #'make-hash-table args) #+allegro (apply #'make-hash-table :values :weak args) #+lispworks (apply #'make-hash-table :weak-kind :value args) + #+openmcl + (apply #'make-hash-table :weak :value args) #-(or cmu sbcl scl allegro lispworks) (apply #'make-hash-table args) ) +#+openmcl +(defclass cleanup-wrapper () + ((cleanup :accessor cleanup :initarg :cleanup) + (value :accessor value :initarg :value))) + +#+openmcl +(defmethod ccl:terminate ((c cleanup-wrapper)) + (funcall (cleanup c))) + (defun get-cache (key cache) + "Get a value from a cache-table." #+(or cmu sbcl) (let ((val (gethash key cache))) (if val (values (weak-pointer-value val) t) (values nil nil))) - #-(or cmu sbcl scl) + #+openmcl + (let ((wrap (gethash key cache))) + (if wrap (values (value wrap) t) + (values nil nil))) + #+(or allegro lispworks) (gethash key cache) ) (defun make-finalizer (key cache) #+(or cmu sbcl) (lambda () (remhash key cache)) - #+allegro + #+(or allegro openmcl) (lambda (obj) (declare (ignore obj)) (remhash key cache)) ) (defun setf-cache (key cache value) + "Set a value in a cache-table." #+(or cmu sbcl) (let ((w (make-weak-pointer value))) (finalize value (make-finalizer key cache)) (setf (gethash key cache) w) value) + #+openmcl + (let ((w (make-instance 'cleanup-wrapper :value value + :cleanup (make-finalizer key cache)))) + (ccl:terminate-when-unreachable w) + (setf (gethash key cache) w) + value) #+allegro (progn (excl:schedule-finalization value (make-finalizer key cache)) (setf (gethash key cache) value)) - #-(or cmu sbcl scl allegro) + #+lispworks (setf (gethash key cache) value) ) (defsetf get-cache setf-cache) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; buffer-stream methods - -(eval-when (:compile-toplevel :load-toplevel) - (defun process-struct-slot-defs (slot-defs struct) - (loop for def in slot-defs - collect (list (first def) (list (second def) struct))))) - -(defmacro with-struct-slots (slot-defs struct &body body) - `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) - , at body)) - -(defun resize-buffer-stream (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (when (> length len) - (let ((newlen (max length (* len 2)))) - (declare (type fixnum newlen)) - (let ((newbuf (allocate-foreign-object :char newlen))) - (copy-bufs newbuf 0 buf 0 len) - (free-foreign-object buf) - (setf buf newbuf) - (setf len newlen) - nil))))) - -(defun finish-buffer (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position)) - bs - (let ((length pos)) - (setf pos 0) - length))) - -(defun buffer-write-byte (b bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 8) b)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 1))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (setf (deref-array buf '(:array :char) pos) b) - (setf pos needed)))) - -(defun buffer-write-int (i bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (signed-byte 32) i)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-int buf i pos) - (setf pos needed) - nil))) - -(defun buffer-write-uint (u bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 32) u)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-uint buf u pos) - (setf pos needed) - nil))) - -(defun buffer-write-float (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type single-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-float buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-double (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type double-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 8))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-double buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-string (s bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type string s)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let* ((str-bytes (byte-length s)) - (needed (+ pos str-bytes))) - (declare (type fixnum str-bytes needed) - (dynamic-extent str-bytes needed)) - (when (> needed len) - (resize-buffer-stream bs needed)) - (copy-str-to-buf buf pos s 0 str-bytes) - (setf pos needed) - nil))) - -(defun buffer-read-byte (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (incf (buffer-stream-position bs)) - (deref-array (buffer-stream-buffer bs) '(:array :char) pos))) - -(defun buffer-read-fixnum (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the fixnum (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-int (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (signed-byte 32) (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-uint (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-float (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (read-float (buffer-stream-buffer bs) pos))) - -(defun buffer-read-double (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 8)) - (read-double (buffer-stream-buffer bs) pos))) - -(defun buffer-read-string (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos length)) - ;; wide!!! - #+(and allegro ics) - (excl:native-to-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length - :external-format :unicode) - #+lispworks - (fli:convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :external-format :unicode :null-terminated-p nil) - #-(or lispworks (and allegro ics)) - (convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :null-terminated-p nil))) From blee at common-lisp.net Thu Sep 16 04:25:20 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:25:20 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26111/tests Modified Files: elephant-tests.lisp Log Message: updates Date: Thu Sep 16 06:25:19 2004 Author: blee Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.2 elephant/tests/elephant-tests.lisp:1.3 --- elephant/tests/elephant-tests.lisp:1.2 Sat Sep 4 11:16:11 2004 +++ elephant/tests/elephant-tests.lisp Thu Sep 16 06:25:19 2004 @@ -44,40 +44,50 @@ (:nicknames ele-tests :ele-tests) (:use common-lisp elephant rt) (:import-from :ele - *out-buf* + with-buffer-streams serialize - deserialize - buffer-stream-buffer) + deserialize) #+cmu (:import-from :pcl finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+sbcl (:import-from :sb-mop finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+allegro (:import-from :clos finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+openmcl (:import-from :ccl finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+lispworks (:import-from :clos finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) ) (in-package :ele-tests) -(defvar *testdb-path* "/usr/local/share/common-lisp/elephant-0.1/tests/testdb") + +(defvar *testdb-path* "/usr/local/share/common-lisp/elephant-0.2/tests/testdb") + +(defun do-all-tests() + (with-open-store (*testdb-path*) + (let ((*auto-commit* nil)) + (do-tests)))) (defun find-slot-def (class-name slot-name) (find-if #'(lambda (slot-def) @@ -103,3 +113,11 @@ (progn , at body) (error () t) (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(defmacro is-not-null (&body body) + `(not (null (progn , at body)))) + +(defmacro are-not-null (&rest forms) + `(values + ,@(loop for form in forms + collect `(is-not-null ,form)))) \ No newline at end of file From blee at common-lisp.net Thu Sep 16 04:26:08 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:26:08 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/mop-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26181/tests Modified Files: mop-tests.lisp Log Message: updates makunbound Date: Thu Sep 16 06:26:08 2004 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.4 elephant/tests/mop-tests.lisp:1.5 --- elephant/tests/mop-tests.lisp:1.4 Sat Sep 4 11:16:11 2004 +++ elephant/tests/mop-tests.lisp Thu Sep 16 06:26:08 2004 @@ -84,7 +84,7 @@ t) (deftest mixes-right-slots - (values + (are-not-null (typep (find-slot-def 'mix-1 'slot1) 'ele::persistent-slot-definition) (typep (find-slot-def 'mix-1 'slot2) 'ele::transient-slot-definition) (typep (find-slot-def 'mix-1 'slot3) 'ele::transient-slot-definition) @@ -115,7 +115,7 @@ t) (deftest inherit-right-slots - (values + (are-not-null (typep (find-slot-def 'make-persistent2 'slot1) 'ele::persistent-slot-definition) (typep (find-slot-def 'make-persistent2 'slot2) @@ -138,13 +138,15 @@ t) (deftest initform-test - (slot-value (make-instance 'p-initform-test) 'slot1) + (let ((*auto-commit* t)) + (slot-value (make-instance 'p-initform-test) 'slot1)) 10) (deftest initarg-test - (values - (slot-value (make-instance 'p-initform-test-2) 'slot1) - (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1)) + (let ((*auto-commit* t)) + (values + (slot-value (make-instance 'p-initform-test-2) 'slot1) + (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1))) 10 20) (deftest no-eval-initform @@ -160,8 +162,19 @@ (progn (defclass redef () () (:metaclass persistent-metaclass)) (defclass redef () () (:metaclass persistent-metaclass)) - (values (subtypep 'redef 'persistent-object))) + (is-not-null (subtypep 'redef 'persistent-object))) t) -(with-open-store (*testdb-path*) - (do-tests)) +;; i wish i could use slot-makunbound but allegro sux +(deftest makunbound + (let ((p (make-instance 'p-class))) + (with-transaction () + (setf (slot1 p) t) + #-allegro + (slot-makunbound p 'slot1) + #+allegro + (slot-makunbound-using-class (find-class 'p-class) p + (find-slot-def 'p-class 'slot1)) + ) + (signals-condition (slot1 p))) + t) \ No newline at end of file From blee at common-lisp.net Thu Sep 16 04:26:37 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:26:37 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testcollections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26292/tests Added Files: testcollections.lisp Log Message: test btrees, secondary indices and cursors Date: Thu Sep 16 06:26:37 2004 Author: blee From blee at common-lisp.net Thu Sep 16 04:27:20 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:27:20 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testserializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv27992/tests Modified Files: testserializer.lisp Log Message: buffer-streamified Date: Thu Sep 16 06:27:19 2004 Author: blee Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.4 elephant/tests/testserializer.lisp:1.5 --- elephant/tests/testserializer.lisp:1.4 Sat Sep 4 11:16:11 2004 +++ elephant/tests/testserializer.lisp Thu Sep 16 06:27:19 2004 @@ -1,23 +1,23 @@ (in-package :ele-tests) (defun in-out-value (var) - (serialize var *out-buf*) - (deserialize (buffer-stream-buffer *out-buf*))) + (with-buffer-streams (out-buf) + (deserialize (serialize var out-buf)))) (defun in-out-eq (var) - (serialize var *out-buf*) - (eq var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (eq var (deserialize (serialize var out-buf))))) (defun in-out-equal (var) - (serialize var *out-buf*) - (equal var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (equal var (deserialize (serialize var out-buf))))) (defun in-out-equalp (var) - (serialize var *out-buf*) - (equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (equalp var (deserialize (serialize var out-buf))))) (deftest fixnums - (values + (are-not-null (in-out-equal 0) (in-out-equal -1) (in-out-equal 1) @@ -26,7 +26,7 @@ t t t t t) (deftest fixnum-type-1 - (values + (are-not-null (typep (in-out-value 0) 'fixnum) (typep (in-out-value 1) 'fixnum) (typep (in-out-value -1) 'fixnum) @@ -35,7 +35,7 @@ t t t t t) (deftest bignums - (values + (are-not-null (in-out-equal 10000000000) (in-out-equal -10000000000) (loop for i from 0 to 2000 @@ -53,7 +53,7 @@ t t t t t t t t) (deftest floats - (values + (are-not-null (in-out-equal 0.0) (in-out-equal -0.0) (in-out-equal 0.0d0) @@ -86,7 +86,7 @@ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t) (deftest rationals - (values + (are-not-null (in-out-equal 1/2) (in-out-equal -1/2) (in-out-equal (/ 1 most-positive-fixnum)) @@ -97,20 +97,21 @@ t t t t t t t) (deftest strings - (values + (are-not-null (in-out-equal "") (in-out-equal "this is a test") (in-out-equal (make-string 400 :initial-element (code-char 254)))) t t t) (defun in-out-uninterned-equal (var) - (serialize var *out-buf*) - (let ((new (deserialize (buffer-stream-buffer *out-buf*)))) - (and (equal (symbol-name new) (symbol-name var)) - (equal (symbol-package new) (symbol-package var))))) + (with-buffer-streams (out-buf) + (serialize var out-buf) + (let ((new (deserialize (serialize var out-buf)))) + (and (equal (symbol-name new) (symbol-name var)) + (equal (symbol-package new) (symbol-package var)))))) (deftest symbols - (values + (are-not-null (in-out-equal nil) (in-out-equal T) (in-out-equal 'foobarbazquux) @@ -131,16 +132,15 @@ (deftest pathnames ;;; Given how implementation-specific make-pathname is, ;;; i don't know how to put more portable tests here! - (values + (are-not-null (in-out-equal #p"/usr/local/share/common-lisp/elephant")) t) (deftest conses - (values + (are-not-null (in-out-equal (cons t 100000)) (in-out-equal (list 1 'a "this is a test" 'c 10000 nil 1000 nil)) - (in-out-equal (cons (cons (cons t nil) (cons nil t)) (cons 1 (cons t nil)))) - ) + (in-out-equal (cons (cons (cons t nil) (cons nil t)) (cons 1 (cons t nil))))) t t t) (deftest hash-tables-1 @@ -150,7 +150,7 @@ (rehash-size (hash-table-rehash-size ht)) (rehash-threshold (hash-table-rehash-threshold ht)) (out (in-out-value ht))) - (values + (are-not-null (eq (hash-table-test out) 'equalp) (= (hash-table-size ht) size) (= (hash-table-rehash-size ht) rehash-size) @@ -169,7 +169,7 @@ (setf (gethash 2 ht) 2.0d0) (setf (gethash 'symbolsymbol ht) "three") (let ((out (in-out-value ht))) - (values + (are-not-null (string= (gethash (cons nil nil) ht) "one") (= (gethash 2 ht) 2.0d0) (string= (gethash 'symbolsymbol ht) "three")))) @@ -179,7 +179,7 @@ (and (subtypep t1 t2) (subtypep t2 t1))) (deftest arrays-1 - (values + (are-not-null (array-has-fill-pointer-p (in-out-value (make-array 200 :fill-pointer t))) (not (array-has-fill-pointer-p @@ -210,7 +210,7 @@ (loop for i from 0 to 99 do (setf (svref svec i) (expt 2 i))) - (values + (are-not-null (in-out-equalp arr) (in-out-equalp vec) (in-out-equalp svec) @@ -279,7 +279,7 @@ (setf (slot-value f 'slot2) f) (setf (slot-value b 'slot1) h) (setf (slot-value b 'slot2) f) - (values + (are-not-null (deep-equalp c1 c1) (deep-equalp c2 c2) (deep-equalp l1 l1) @@ -290,11 +290,11 @@ t t t t t t t) (defun in-out-deep-equalp (var) - (serialize var *out-buf*) - (deep-equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + (with-buffer-streams (out-buf) + (deep-equalp var (deserialize (serialize var out-buf))))) (deftest objects - (values + (are-not-null (in-out-deep-equalp (make-instance 'foo)) (in-out-deep-equalp (make-instance 'bar :slot1 (make-instance 'foo @@ -323,7 +323,7 @@ (setf (slot-value f 'slot2) f) (setf (slot-value b 'slot1) h) (setf (slot-value b 'slot2) f) - (values + (are-not-null (in-out-deep-equalp c1) (in-out-deep-equalp c2) (in-out-deep-equalp l1) @@ -342,12 +342,13 @@ (:metaclass persistent-metaclass)) (deftest persistent - (let ((f1 (make-instance 'pfoo)) - (f2 (make-instance 'pfoo :slot1 "this is a string")) - (b1 (make-instance 'pbar :slot2 "another string")) - (b2 (make-instance 'pbar)) - (h (make-instance 'btree))) - (values + (let* ((*auto-commit* t) + (f1 (make-instance 'pfoo)) + (f2 (make-instance 'pfoo :slot1 "this is a string")) + (b1 (make-instance 'pbar :slot2 "another string")) + (b2 (make-instance 'pbar)) + (h (make-instance 'btree))) + (are-not-null (in-out-eq f1) (in-out-eq f2) (in-out-eq b1) @@ -360,4 +361,3 @@ (progn (setf (get-value f2 h) f2) (eq (get-value f2 h) f2)))) t t t t t t t t) - \ No newline at end of file From blee at common-lisp.net Thu Sep 16 04:28:06 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:28:06 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testsleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv28278/tests Modified Files: testsleepycat.lisp Log Message: first stab at RT-ifying Date: Thu Sep 16 06:28:05 2004 Author: blee Index: elephant/tests/testsleepycat.lisp diff -u elephant/tests/testsleepycat.lisp:1.1 elephant/tests/testsleepycat.lisp:1.2 --- elephant/tests/testsleepycat.lisp:1.1 Mon Aug 30 23:40:38 2004 +++ elephant/tests/testsleepycat.lisp Thu Sep 16 06:28:05 2004 @@ -1,4 +1,5 @@ +(in-package "ELE-TESTS") (use-package "SLEEPYCAT") (defvar env) @@ -21,28 +22,37 @@ (db-open db :file "foo" :database "bar" :type DB-BTREE :auto-commit t :create t :thread t)) -(defun put-alot (keys) +(deftest prepares + (finishes (prepare)) t) + +(deftest put-alot + (finishes + (loop for key in keys + do + (db-put db key key :auto-commit t))) + t) + +(defun get-alot () (loop for key in keys - with datum = "mydatum" - do - (db-put db key datum :auto-commit t))) + always (string= key (db-get db key)))) + +(deftest put-right (get-alot) t) -(defun put-alot-b (keys) - (with-transaction (:environment env) - (loop for key in keys - do - (db-put db key "mydatum")))) +(deftest put-alot-b + (finishes + (with-transaction (:environment env) + (loop for key in keys + do + (db-put db key key)))) + t) + +(deftest put-right-b (get-alot) t) (defun txn-alot (iters) (loop for i from 1 to iters do (with-transaction (:environment env) (db-put db "mykey" "mydatum")))) - -(defun get-alot (keys) - (loop for key in keys - do - (db-get db key))) (defun get-alot-b (keys) (loop for key in keys From blee at common-lisp.net Thu Sep 16 04:29:20 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:29:20 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testsorter.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv28436/tests Added Files: testsorter.lisp Log Message: initiali version Date: Thu Sep 16 06:29:19 2004 Author: blee From blee at common-lisp.net Thu Sep 16 04:22:43 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 16 Sep 2004 06:22:43 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25936/src Modified Files: sleepycat.lisp Log Message: split off berkeley-db doc-strings buffer-streamified cmu pointer arithmetic Date: Thu Sep 16 06:22:41 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.9 elephant/src/sleepycat.lisp:1.10 --- elephant/src/sleepycat.lisp:1.9 Thu Sep 2 16:47:09 2004 +++ elephant/src/sleepycat.lisp Thu Sep 16 06:22:41 2004 @@ -42,20 +42,54 @@ (defpackage sleepycat + (:documentation "A low-level UFFI-based interface to +Berkeley DB / Sleepycat, via the libsleepycat.c wrapper. +Partly intended to be usable outside Elephant, but with some +magic for Elephant. In general there is a 1-1 mapping from +functions here and functions in Sleepycat, so refer to their +documentation for details.") (:use common-lisp uffi) + #+cmu + (:use alien) + #+sbcl + (:use sb-alien) + #+cmu + (:import-from :sys + #:sap+) + #+sbcl + (:import-from :sb-sys + #:sap+) + #+openmcl + (:import-from :ccl + #:byte-length) (:export #:*current-transaction* - #:read-int #:read-uint #:read-float #:read-double - #:write-int #:write-uint #:write-float #:write-double - #:offset-char-pointer #:copy-str-to-buf #:copy-bufs #:byte-length + + #:buffer-stream #:make-buffer-stream #:with-buffer-streams + #:resize-buffer-stream #:resize-buffer-stream-no-copy + #:reset-buffer-stream #:buffer-stream-buffer + #:buffer-write-byte #:buffer-write-int + #:buffer-write-uint #:buffer-write-float #:buffer-write-double + #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum + #:buffer-read-int #:buffer-read-uint #:buffer-read-float + #:buffer-read-double #:buffer-read-string #:byte-length + #:pointer-int #:pointer-void #:array-or-pointer-char + #:db-env-create #:db-env-close #:db-env-open #:db-env-dbremove #:db-env-dbrename #:db-env-remove #:db-env-set-flags #:db-env-get-flags #:db-create #:db-close #:db-open #:db-remove #:db-rename #:db-sync #:db-truncate + #:db-set-flags #:db-get-flags #:db-get-key-buffered #:db-get-buffered #:db-get #:db-put-buffered #:db-put #:db-delete-buffered #:db-delete + #:db-cursor #:db-cursor-close #:db-cursor-delete + #:db-cursor-duplicate + #:db-cursor-move-buffered #:db-cursor-set-buffered + #:db-cursor-get-both-buffered + #:db-cursor-pmove-buffered #:db-cursor-pset-buffered + #:db-cursor-pget-both-buffered #:db-cursor-put-buffered #:db-transaction-begin #:db-transaction-abort #:db-transaction-commit #:with-transaction #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free @@ -63,6 +97,7 @@ #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-lock-detect #:db-env-get-lock-detect #:db-error #:db-error-errno + #:+NULL-VOID+ #:+NULL-CHAR+ #:DB-BTREE #:DB-HASH #:DB-QUEUE #:DB-RECNO #:DB-UNKNOWN #:DB_KEYEMPTY #:DB_LOCK_DEADLOCK #:DB_LOCK_NOTGRANTED @@ -74,6 +109,10 @@ (in-package "SLEEPYCAT") +#+cmu +(eval-when (:compile-toplevel) + (proclaim '(optimize (ext:inhibit-warnings 3)))) + (eval-when (:compile-toplevel :load-toplevel) ;; UFFI ;;(asdf:operate 'asdf:load-op :uffi) @@ -98,14 +137,14 @@ #+(or bsd freebsd) "/usr/local/lib/db42/libdb.so" #+darwin - "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" + "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" :module "sleepycat") (error "Couldn't load libdb (Sleepycat)!")) ;; Libsleepycat.so: edit this (unless (uffi:load-foreign-library - "/usr/local/share/common-lisp/elephant-0.1/libsleepycat.so" + "/usr/local/share/common-lisp/elephant-0.2/libsleepycat.so" :module "libsleepycat") (error "Couldn't load libsleepycat!")) @@ -123,16 +162,15 @@ (declaim (inline read-int read-uint read-float read-double write-int write-uint write-float write-double offset-char-pointer copy-str-to-buf copy-bufs - %db-get-key-buffered db-get-key-buffered - %db-get-buffered db-get-buffered db-get - %db-put-buffered db-put-buffered - %db-put db-put - %db-delete db-delete-buffered db-delete - %db-txn-begin db-transaction-begin - %db-txn-abort db-transaction-abort - %db-txn-commit db-transaction-commit - %db-transaction-id - flags)) + ;;resize-buffer-stream + ;;buffer-stream-buffer buffer-stream-size buffer-stream-position + ;;buffer-stream-length + reset-buffer-stream + buffer-write-byte buffer-write-int buffer-write-uint + buffer-write-float buffer-write-double buffer-write-string + buffer-read-byte buffer-read-fixnum buffer-read-int + buffer-read-uint buffer-read-float buffer-read-double + buffer-read-string)) ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -169,81 +207,293 @@ (defconstant DB_TXN_NOWAIT #x0001000) (defconstant DB_TXN_SYNC #x0002000) (defconstant DB_LOCK_NOWAIT #x001) +(defconstant DB_DUP #x0000002) +(defconstant DB_DUPSORT #x0000004) -(defconstant DB_GET_BOTH 10) -(defconstant DB_SET_LOCK_TIMEOUT 29) -(defconstant DB_SET_TXN_TIMEOUT 33) - -(defconstant DB_KEYEMPTY -30997) -(defconstant DB_LOCK_DEADLOCK -30995) -(defconstant DB_LOCK_NOTGRANTED -30994) -(defconstant DB_NOTFOUND -30990) +(defconstant DB_CURRENT 7) +(defconstant DB_FIRST 9) +(defconstant DB_GET_BOTH 10) +(defconstant DB_GET_BOTH_RANGE 12) +(defconstant DB_LAST 17) +(defconstant DB_NEXT 18) +(defconstant DB_NEXT_DUP 19) +(defconstant DB_NEXT_NODUP 20) +(defconstant DB_PREV 25) +(defconstant DB_PREV_NODUP 26) +(defconstant DB_SET 28) +(defconstant DB_SET_RANGE 30) + +(defconstant DB_AFTER 1) +(defconstant DB_BEFORE 3) +(defconstant DB_KEYFIRST 15) +(defconstant DB_KEYLAST 16) + +(defconstant DB_NODUPDATA 21) +(defconstant DB_NOOVERWRITE 22) +(defconstant DB_NOSYNC 23) + +(defconstant DB_POSITION 24) + +(defconstant DB_SET_LOCK_TIMEOUT 29) +(defconstant DB_SET_TXN_TIMEOUT 33) + +(defconstant DB_KEYEMPTY -30997) +(defconstant DB_KEYEXIST -30996) +(defconstant DB_LOCK_DEADLOCK -30995) +(defconstant DB_LOCK_NOTGRANTED -30994) +(defconstant DB_NOTFOUND -30990) -(defvar +NULL-VOID+ (make-null-pointer :void)) -(defvar +NULL-CHAR+ (make-null-pointer :char)) +(defconstant DB_LOCK_DEFAULT 1) +(defconstant DB_LOCK_EXPIRE 2) +(defconstant DB_LOCK_MAXLOCKS 3) +(defconstant DB_LOCK_MINLOCKS 4) +(defconstant DB_LOCK_MINWRITE 5) +(defconstant DB_LOCK_OLDEST 6) +(defconstant DB_LOCK_RANDOM 7) +(defconstant DB_LOCK_YOUNGEST 8) +(defvar +NULL-VOID+ (make-null-pointer :void) + "A null pointer to a void type.") +(defvar +NULL-CHAR+ (make-null-pointer :char) + "A null pointer to a char type.") -;; Buffer management / pointer arithmetic -;; Notes: on CMUCL and Allegro: with-cast-pointer + -;; deref-array is faster than FFI + C pointer arithmetic. -;; however pointer arithmetic is usually consing. OpenMCL -;; supports non-consing pointer arithmentic though. +(def-enum DB-LOCKOP ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT + :PUT :PUT-ALL :PUT-OBJ :PUT-READ + :TIMEOUT :TRADE :UPGRADE-WRITE)) +(def-enum DB-LOCKMODE ((:NG 0) :READ :WRITE :WAIT + :IWRITE :IREAD :IWR :DIRTY :WWRITE)) -;; TODO: #+openmcl versions which do macptr arith. +(def-struct DB-LOCK + (off :unsigned-int) + (ndx :unsigned-int) + (gen :unsigned-int) + (mode DB-LOCKMODE)) + +#+openmcl +(ccl:def-foreign-type DB-LOCK (:struct DB-LOCK)) + +(def-struct DB-LOCKREQ + (op DB-LOCKOP) + (mode DB-LOCKMODE) + (timeout :unsigned-int) + (obj (:array :char)) + (lock (* DB-LOCK))) + +#+openmcl +(ccl:def-foreign-type DB-LOCKREQ (:struct DB-LOCKREQ)) + + +;; Thread local storage (special variables) + +(defvar *current-transaction* +NULL-VOID+ + "The transaction which is currently in effect.") + +(defvar *errno-buffer* (allocate-foreign-object :int 1) + "Resourced space for errno return values.") +(defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) + "Vector of buffer-streams, which you can grab / return.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; buffer-streams +;;; +;;; a stream-like interface for our buffers; methods are +;;; below. ultimately we might want a gray / simple -stream +;;; for real, for now who cares? + +(defstruct buffer-stream + "A stream-like interface to foreign (alien) char buffers." + (buffer (allocate-foreign-object :char 10) :type array-or-pointer-char) + (size 0 :type fixnum) + (position 0 :type fixnum) + (length 10 :type fixnum)) + +(defun grab-buffer-stream () + "Grab a buffer-stream from the *buffer-streams* resource pool." + (declare (optimize (speed 3))) + (if (= (length *buffer-streams*) 0) + (make-buffer-stream) + (vector-pop *buffer-streams*))) + +(defun return-buffer-stream (bs) + "Return a buffer-stream to the *buffer-streams* resource pool." + (declare (optimize (speed 3))) + (reset-buffer-stream bs) + (vector-push-extend bs *buffer-streams*)) + +(defmacro with-buffer-streams (names &body body) + "Grab a buffer-stream, executes forms, and returns the +stream to the pool on exit." + `(let ,(loop for name in names collect (list name '(grab-buffer-stream))) + (unwind-protect + (progn , at body) + (progn + ,@(loop for name in names + collect (list 'return-buffer-stream name)))))) + +;; Buffer management / pointer arithmetic + +;; Notes: on Allegro: with-cast-pointer + deref-array is +;; faster than FFI + C pointer arithmetic. however pointer +;; arithmetic is usually consing. OpenMCL supports +;; non-consing pointer arithmentic though. Check these +;; CMUCL / SBCL things don't cons unless necessary. + +;; TODO: #+openmcl versions which do macptr arith. + +#+(or cmu sbcl) +(defun read-int (buf offset) + "Read a 32-bit signed integer from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the (signed-byte 32) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* integer))))) + +#+(or cmu sbcl) +(defun read-uint (buf offset) + "Read a 32-bit unsigned integer from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the (unsigned-byte 32) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (unsigned 32)))))) + +#+(or cmu sbcl) +(defun read-float (buf offset) + "Read a single-float from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the single-float + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* single-float))))) + +#+(or cmu sbcl) +(defun read-double (buf offset) + "Read a double-float from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the double-float + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* double-float))))) + +#+(or cmu sbcl) +(defun write-int (buf num offset) + "Write a 32-bit signed integer to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type (signed-byte 32) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* integer))) num)) + +#+(or cmu sbcl) +(defun write-uint (buf num offset) + "Write a 32-bit unsigned integer to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type (unsigned-byte 32) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (unsigned 32)))) num)) + +#+(or cmu sbcl) +(defun write-float (buf num offset) + "Write a single-float to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type single-float num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* single-float))) num)) + +#+(or cmu sbcl) +(defun write-double (buf num offset) + "Write a double-float to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type double-float num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* double-float))) num)) + +#+(or cmu sbcl) +(defun offset-char-pointer (p offset) + "Pointer arithmetic." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) p) + (type fixnum offset)) + (sap-alien (sap+ (alien-sap p) offset) (* char))) +#-(or cmu sbcl) (def-function ("read_int" read-int) ((buf array-or-pointer-char) (offset :int)) :returning :int) +#-(or cmu sbcl) (def-function ("read_uint" read-uint) ((buf array-or-pointer-char) (offset :int)) :returning :unsigned-int) +#-(or cmu sbcl) (def-function ("read_float" read-float) ((buf array-or-pointer-char) (offset :int)) :returning :float) +#-(or cmu sbcl) (def-function ("read_double" read-double) ((buf array-or-pointer-char) (offset :int)) :returning :double) +#-(or cmu sbcl) (def-function ("write_int" write-int) ((buf array-or-pointer-char) (num :int) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("write_uint" write-uint) ((buf array-or-pointer-char) (num :unsigned-int) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("write_float" write-float) ((buf array-or-pointer-char) (num :float) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("write_double" write-double) ((buf array-or-pointer-char) (num :double) (offset :int)) :returning :void) +#-(or cmu sbcl) (def-function ("offset_charp" offset-char-pointer) ((p array-or-pointer-char) (offset :int)) :returning array-or-pointer-char) ;; Allegro and Lispworks use 16-bit unicode characters +#+(or cmu sbcl allegro lispworks) (defmacro byte-length (s) + "Return the number of bytes of the internal representation +of a string." #+(or lispworks (and allegro ics)) `(let ((l (length ,s))) (+ l l)) #-(or lispworks (and allegro ics)) @@ -274,6 +524,7 @@ ;; but OpenMCL can't directly pass string bytes. #+openmcl (defun copy-str-to-buf (dest dest-offset src src-offset length) + "Copy a string to a foreign buffer. From Gary Byers." (declare (optimize (speed 3) (safety 0)) (type string src) (type array-or-pointer-char dest) @@ -287,6 +538,7 @@ ;; Lisp version, for kicks. this assumes 8-bit chars! #+(not (or cmu sbcl scl allegro openmcl lispworks)) (defun copy-str-to-buf (dest dest-offset src src-offset length) + "Copy a string to a foreign buffer." (declare (optimize (speed 3) (safety 0)) (type string src) (type array-or-pointer-char dest) @@ -313,36 +565,240 @@ (length :int)) :returning :void) -;; Thread local storage (special variables) -(declaim (type array-or-pointer-char *get-buffer*) - (type fixnum *get-buffer-length*)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; buffer-stream functions + +(eval-when (:compile-toplevel) + (defun process-struct-slot-defs (slot-defs struct) + (loop for def in slot-defs + collect (list (first def) (list (second def) struct))))) + +(defmacro with-struct-slots (slot-defs struct &body body) + `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) + , at body)) + +(defun resize-buffer-stream (bs length) + "Resize the underlying buffer of a buffer-stream, copying the old data." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum length)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (when (> length len) + (let ((newlen (max length (* len 2)))) + (declare (type fixnum newlen)) + (let ((newbuf (allocate-foreign-object :char newlen))) + ;; technically we just need to copy from position to size..... + (copy-bufs newbuf 0 buf 0 size) + (free-foreign-object buf) + (setf buf newbuf) + (setf len newlen) + nil))))) + +(defun resize-buffer-stream-no-copy (bs length) + "Resize the underlying buffer of a buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum length)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (when (> length len) + (let ((newlen (max length (* len 2)))) + (declare (type fixnum newlen)) + (let ((newbuf (allocate-foreign-object :char newlen))) + (free-foreign-object buf) + (setf buf newbuf) + (setf len newlen) + nil))))) -(defvar *current-transaction* +NULL-VOID+) +(defun reset-buffer-stream (bs) + "'Empty' the buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (setf (buffer-stream-size bs) 0) + (setf (buffer-stream-position bs) 0)) -(defvar *errno-buffer* (allocate-foreign-object :int 1)) +(defun buffer-write-byte (b bs) + "Write a byte." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 8) b)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 1))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (setf (deref-array buf '(:array :char) size) b) + (setf size needed)))) -(defvar *get-buffer* (allocate-foreign-object :char 1)) -(defvar *get-buffer-length* 0) +(defun buffer-write-int (i bs) + "Write a 32-bit signed integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (signed-byte 32) i)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-int buf i size) + (setf size needed) + nil))) -(defun resize-get-buffer (length) - (declare (optimize (speed 3) (safety 0) (space 0)) +(defun buffer-write-uint (u bs) + "Write a 32-bit unsigned integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 32) u)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-uint buf u size) + (setf size needed) + nil))) + +(defun buffer-write-float (d bs) + "Write a single-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type single-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-float buf d size) + (setf size needed) + nil))) + +(defun buffer-write-double (d bs) + "Write a double-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type double-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 8))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-double buf d size) + (setf size needed) + nil))) + +(defun buffer-write-string (s bs) + "Write the underlying bytes of a string. On Unicode +Lisps, this is a 16-bit operation." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type string s)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let* ((str-bytes (byte-length s)) + (needed (+ size str-bytes))) + (declare (type fixnum str-bytes needed) + (dynamic-extent str-bytes needed)) + (when (> needed len) + (resize-buffer-stream bs needed)) + (copy-str-to-buf buf size s 0 str-bytes) + (setf size needed) + nil))) + +(defun buffer-read-byte (bs) + "Read a byte." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (incf (buffer-stream-position bs)) + (deref-array (buffer-stream-buffer bs) '(:array :char) position))) + +(defun buffer-read-fixnum (bs) + "Read a 32-bit signed integer, which is assumed to be a fixnum." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the fixnum (read-int (buffer-stream-buffer bs) position)))) + +(defun buffer-read-int (bs) + "Read a 32-bit signed integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the (signed-byte 32) (read-int (buffer-stream-buffer bs) position)))) + +(defun buffer-read-uint (bs) + "Read a 32-bit unsigned integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) position)))) + +(defun buffer-read-float (bs) + "Read a single-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (read-float (buffer-stream-buffer bs) position))) + +(defun buffer-read-double (bs) + "Read a double-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 8)) + (read-double (buffer-stream-buffer bs) position))) + +(defun buffer-read-string (bs length) + "Read a string. On Unicode Lisps this is a 16-bit operation!" + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) (type fixnum length)) - (if (< length *get-buffer-length*) - (values *get-buffer* *get-buffer-length*) - (let ((newlen (max length (* *get-buffer-length* 2)))) - (declare (type fixnum newlen)) - (setq *get-buffer-length* newlen) - (free-foreign-object *get-buffer*) - (setq *get-buffer* (allocate-foreign-object :char newlen)) - (values *get-buffer* *get-buffer-length*)))) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position length)) + ;; wide!!! + #+(and allegro ics) + (excl:native-to-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length + :external-format :unicode) + #+lispworks + (fli:convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length :external-format :unicode :null-terminated-p nil) + #-(or lispworks (and allegro ics)) + (convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length :null-terminated-p nil))) ;; Wrapper macro -- handles errno return values ;; makes flags into keywords ;; makes keyword args, cstring wrappers -(eval-when (:compile-toplevel :load-toplevel) +(eval-when (:compile-toplevel) (defun make-wrapper-args (args flags keys) (if (or flags keys) (append (remove-keys (remove 'flags args) keys) @@ -378,6 +834,7 @@ (defmacro wrap-errno (names args &key (keys nil) (flags nil) (cstrings nil) (outs 1) (declarations nil) + (documentation nil) (transaction nil)) (let ((wname (if (listp names) (first names) names)) (fname (if (listp names) (second names) @@ -388,7 +845,8 @@ (if (> outs 1) (let ((out-args (make-out-args outs))) `(defun ,wname ,wrapper-args - ,@(if declarations (list declarations) (values)) + ,@(if documentation (list documentation) (values)) + ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (multiple-value-bind ,out-args (,fname , at fun-args) @@ -399,10 +857,11 @@ ,@(if transaction (list `((or (= ,errno DB_LOCK_DEADLOCK) (= ,errno DB_LOCK_NOTGRANTED)) - (throw ,transaction ,transaction))) + (throw 'transaction ,transaction))) (values)) (t (error 'db-error :errno ,errno)))))))) `(defun ,wname ,wrapper-args + ,@(if documentation (list documentation) (values)) ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (let ((,errno (,fname , at fun-args))) @@ -412,769 +871,71 @@ ,@(if transaction (list `((or (= ,errno DB_LOCK_DEADLOCK) (= ,errno DB_LOCK_NOTGRANTED)) - (throw ,transaction ,transaction))) + (throw 'transaction ,transaction))) (values)) (t (error 'db-error :errno ,errno))))))))) +(defmacro flags (&key auto-commit joinenv init-cdb init-lock init-log + init-mpool init-rep init-txn recover recover-fatal lockdown + private system-mem thread force dirty-read create excl nommap + rdonly truncate txn-nosync txn-nowait txn-sync lock-nowait + dup dup-sort current first get-both get-both-range last next + next-dup next-nodup prev prev-nodup set set-range + after before keyfirst keylast + no-dup-data no-overwrite nosync position set-lock-timeout + set-transaction-timeout) + (let ((flags (gensym))) + `(let ((,flags 0)) + (declare (type fixnum ,flags)) + ,@(when auto-commit `((when ,auto-commit (setq ,flags (logior ,flags DB_AUTO_COMMIT))))) + ,@(when joinenv `((when ,joinenv (setq ,flags (logior ,flags DB_JOINENV))))) + ,@(when init-cdb `((when ,init-cdb (setq ,flags (logior ,flags DB_INIT_CDB))))) + ,@(when init-lock `((when ,init-lock (setq ,flags (logior ,flags DB_INIT_LOCK))))) + ,@(when init-log `((when ,init-log (setq ,flags (logior ,flags DB_INIT_LOG))))) + ,@(when init-mpool `((when ,init-mpool (setq ,flags (logior ,flags DB_INIT_MPOOL))))) + ,@(when init-rep `((when ,init-rep (setq ,flags (logior ,flags DB_INIT_REP))))) + ,@(when init-txn `((when ,init-txn (setq ,flags (logior ,flags DB_INIT_TXN))))) + ,@(when recover `((when ,recover (setq ,flags (logior ,flags DB_RECOVER))))) + ,@(when recover-fatal `((when ,recover-fatal (setq ,flags (logior ,flags DB_RECOVER_FATAL))))) + ,@(when lockdown `((when ,lockdown (setq ,flags (logior ,flags DB_LOCKDOWN))))) + ,@(when private `((when ,private (setq ,flags (logior ,flags DB_PRIVATE))))) + ,@(when system-mem `((when ,system-mem (setq ,flags (logior ,flags DB_SYSTEM_MEM))))) + ,@(when thread `((when ,thread (setq ,flags (logior ,flags DB_THREAD))))) + ,@(when force `((when ,force (setq ,flags (logior ,flags DB_FORCE))))) + ,@(when dirty-read `((when ,dirty-read (setq ,flags (logior ,flags DB_DIRTY_READ))))) + ,@(when create `((when ,create (setq ,flags (logior ,flags DB_CREATE))))) + ,@(when excl `((when ,excl (setq ,flags (logior ,flags DB_EXCL))))) + ,@(when nommap `((when ,nommap (setq ,flags (logior ,flags DB_NOMMAP))))) + ,@(when rdonly `((when ,rdonly (setq ,flags (logior ,flags DB_RDONLY))))) + ,@(when truncate `((when ,truncate (setq ,flags (logior ,flags DB_TRUNCATE))))) + ,@(when txn-nosync `((when ,txn-nosync (setq ,flags (logior ,flags DB_TXN_NOSYNC))))) + ,@(when txn-nowait `((when ,txn-nowait (setq ,flags (logior ,flags DB_TXN_NOWAIT))))) + ,@(when txn-sync `((when ,txn-sync (setq ,flags (logior ,flags DB_TXN_SYNC))))) + ,@(when lock-nowait `((when ,lock-nowait (setq ,flags (logior ,flags DB_LOCK_NOWAIT))))) + ,@(when dup `((when ,dup (setq ,flags (logior ,flags DB_DUP))))) + ,@(when dup-sort `((when ,dup-sort (setq ,flags (logior ,flags DB_DUPSORT))))) + ,@(when current `((when ,current (setq ,flags (logior ,flags DB_CURRENT))))) + ,@(when first `((when ,first (setq ,flags (logior ,flags DB_FIRST))))) + ,@(when get-both `((when ,get-both (setq ,flags (logior ,flags DB_GET_BOTH))))) + ,@(when get-both-range `((when ,get-both-range (setq ,flags (logior ,flags DB_GET_BOTH_RANGE))))) + ,@(when last `((when ,last (setq ,flags (logior ,flags DB_LAST))))) + ,@(when next `((when ,next (setq ,flags (logior ,flags DB_NEXT))))) + ,@(when next-dup `((when ,next-dup (setq ,flags (logior ,flags DB_NEXT_DUP))))) + ,@(when next-nodup `((when ,next-nodup (setq ,flags (logior ,flags DB_NEXT_NODUP))))) + ,@(when prev `((when ,prev (setq ,flags (logior ,flags DB_PREV))))) + ,@(when prev-nodup `((when ,prev-nodup (setq ,flags (logior ,flags DB_PREV_NODUP))))) + ,@(when set `((when ,set (setq ,flags (logior ,flags DB_SET))))) + ,@(when set-range `((when ,set-range (setq ,flags (logior ,flags DB_SET_RANGE))))) + ,@(when after `((when ,after (setq ,flags (logior ,flags DB_AFTER))))) + ,@(when before `((when ,before (setq ,flags (logior ,flags DB_BEFORE))))) + ,@(when keyfirst `((when ,keyfirst (setq ,flags (logior ,flags DB_KEYFIRST))))) + ,@(when keylast `((when ,keylast (setq ,flags (logior ,flags DB_KEYLAST))))) + ,@(when no-dup-data `((when ,no-dup-data (setq ,flags (logior ,flags DB_NODUPDATA))))) + ,@(when no-overwrite `((when ,no-overwrite (setq ,flags (logior ,flags DB_NOOVERWRITE))))) + ,@(when nosync `((when ,nosync (setq ,flags (logior ,flags DB_NOSYNC))))) + ,@(when position `((when ,position (setq ,flags (logior ,flags DB_POSITION))))) + ,@(when set-lock-timeout `((when ,set-lock-timeout (setq ,flags (logior ,flags DB_SET_LOCK_TIMEOUT))))) + ,@(when set-transaction-timeout `((when ,set-transaction-timeout (setq ,flags (logior ,flags DB_SET_TXN_TIMEOUT))))) + ,flags))) -;; Environment - -(def-function ("db_env_cr" %db-env-create) - ((flags :unsigned-int) - (errno :int :out)) - :returning :pointer-void) - -(defun db-env-create () - (multiple-value-bind (env errno) - (%db-env-create 0) - (declare (type fixnum errno)) - (if (= errno 0) - env - (error 'db-error :errno errno)))) - -(def-function ("db_env_close" %db-env-close) - ((dbenvp :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-close (dbenvp flags)) - -(def-function ("db_env_open" %db-env-open) - ((dbenvp :pointer-void) - (home :cstring) - (flags :unsigned-int) - (mode :int)) - :returning :int) - -(wrap-errno db-env-open (dbenvp home flags mode) - :flags (joinenv init-cdb init-lock init-log - init-mpool init-rep init-txn - recover recover-fatal create - lockdown private system-mem thread) - :keys ((mode #o640)) - :cstrings (home)) - -(def-function ("db_env_dbremove" %db-env-dbremove) - ((env :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-dbremove (env transaction file database flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*) - (database +NULL-CHAR+)) - :cstrings (file database) - :transaction transaction) - -(def-function ("db_env_dbrename" %db-env-dbrename) - ((env :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (newname :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-dbrename (env transaction file database newname flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*) - (database +NULL-CHAR+)) - :cstrings (file database newname) - :transaction transaction) - -(def-function ("db_env_remove" %db-env-remove) - ((env :pointer-void) - (home :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-remove (env home flags) :flags (force) - :cstrings (home)) - -(def-function ("db_env_set_flags" %db-env-set-flags) - ((env :pointer-void) - (flags :unsigned-int) - (onoff :int)) - :returning :int) - -(wrap-errno db-env-set-flags (env flags onoff) - :flags (auto-commit nommap txn-nosync)) - -(def-function ("db_env_get_flags" %db-env-get-flags) - ((env :pointer-void) - (flags :unsigned-int :out)) - :returning :int) - -(wrap-errno db-env-get-flags (env) :outs 2) - - -;; Database - -(def-function ("db_cr" %db-create) - ((dbenv :pointer-void) - (flags :unsigned-int) - (errno :int :out)) - :returning :pointer-void) - -(defun db-create (&optional (dbenv +NULL-VOID+)) - (multiple-value-bind (db errno) - (%db-create dbenv 0) - (declare (type fixnum errno)) - (if (= errno 0) - db - (error 'db-error :errno errno)))) - -(def-function ("db_close" %db-close) - ((db :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-close (db flags)) - -(def-function ("db_open" %db-open) - ((db :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (type DBTYPE) - (flags :unsigned-int) - (mode :int)) - :returning :int) - -(wrap-errno db-open (db transaction file database type flags mode) - :flags (auto-commit create dirty-read excl nommap - rdonly thread truncate) - :keys ((transaction *current-transaction*) - (file +NULL-CHAR+) - (database +NULL-CHAR+) - (type DB-UNKNOWN) - (mode #o640)) - :cstrings (file database) - :transaction transaction) - -(def-function ("db_remove" %db-remove) - ((db :pointer-void) - (file :cstring) - (database :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-remove (db file database flags) - :keys ((database +NULL-CHAR+)) - :cstrings (file database)) - -(def-function ("db_rename" %db-rename) - ((db :pointer-void) - (file :cstring) - (database :cstring) - (newname :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-rename (db file database newname flags) - :keys ((database +NULL-CHAR+)) - :cstrings (file database newname)) - -(def-function ("db_sync" %db-sync) - ((db :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-sync (db flags)) - -(def-function ("db_truncate" %db-truncate) - ((db :pointer-void) - (txn :pointer-void) - (count :unsigned-int :out) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-truncate (db transaction flags) :flags (auto-commit) - :keys ((transaction *current-transaction*)) :outs 2 - :transaction transaction) - -;; Accessors - -(def-function ("db_get_raw" %db-get-key-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (buffer array-or-pointer-char) - (buffer-length :unsigned-int) - (flags :unsigned-int) - (result-length :unsigned-int :out)) - :returning :int) - -(defun db-get-key-buffered (db key-buffer key-length &key - (transaction *current-transaction*) - auto-commit get-both dirty-read) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type array-or-pointer-char key-buffer) - (type fixnum key-length) - (type boolean auto-commit get-both dirty-read)) - (loop - do - (multiple-value-bind (errno result-length) - (%db-get-key-buffered db transaction key-buffer key-length - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get-key-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length)))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get-key-buffered - (the (values null fixnum) (values nil 0)))) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length))))) - -(def-function ("db_get_raw" %db-get-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (buffer array-or-pointer-char) - (buffer-length :unsigned-int) - (flags :unsigned-int) - (result-length :unsigned-int :out)) - :returning :int) - -(defun db-get-buffered (db key &key - (key-length (length key)) - (transaction *current-transaction*) - auto-commit get-both dirty-read) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key) - (type fixnum key-length) - (type boolean auto-commit get-both dirty-read)) - (with-cstring (k key) - (loop - do - (multiple-value-bind (errno result-length) - (%db-get-buffered db transaction k key-length - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length)))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get-buffered - (the (values null fixnum) (values nil 0)))) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length)))))) - -(defun db-get (db key &key (key-length (length key)) - (transaction *current-transaction*) - auto-commit get-both dirty-read) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key) - (type fixnum key-length) - (type boolean auto-commit get-both dirty-read)) - (with-cstring (k key) - (loop - do - (multiple-value-bind (errno result-length) - (%db-get-buffered db transaction k key-length - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get - (convert-from-foreign-string *get-buffer* - :length result-length - :null-terminated-p nil))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get nil)) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length)))))) - -(def-function ("db_put_raw" %db-put-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (datum array-or-pointer-char) - (datum-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-put-buffered (db transaction key key-length - datum datum-length flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type array-or-pointer-char key datum) - (type fixnum key-length datum-length) - (type boolean auto-commit)) - :transaction transaction) - -(def-function ("db_put_raw" %db-put) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (datum :cstring) - (datum-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-put (db transaction key key-length datum datum-length flags) - :flags (auto-commit) - :keys ((key-length (length key)) - (datum-length (length datum)) - (transaction *current-transaction*)) - :cstrings (key datum) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key datum) - (type fixnum key-length datum-length) - (type boolean auto-commit)) - :transaction transaction) - -(def-function ("db_del" %db-delete-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(defun db-delete-buffered (db key key-length &key auto-commit - (transaction *current-transaction*)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) (type array-or-pointer-char key) - (type fixnum key-length) (type boolean auto-commit)) - (let ((errno (%db-delete-buffered db transaction - key key-length - (flags :auto-commit auto-commit)))) - (declare (type fixnum errno)) - (cond ((= errno 0) t) - ((or (= errno DB_NOTFOUND) - (= errno DB_KEYEMPTY)) - nil) - ((or (= errno DB_LOCK_DEADLOCK) - (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))))) - -(def-function ("db_del" %db-delete) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(defun db-delete (db key &key auto-commit (key-length (length key)) - (transaction *current-transaction*)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) (type string key) - (type fixnum key-length) (type boolean auto-commit)) - (with-cstrings ((key key)) - (let ((errno - (%db-delete db transaction key - key-length (flags :auto-commit auto-commit)))) - (declare (type fixnum errno)) - (cond ((= errno 0) nil) - ((or (= errno DB_NOTFOUND) - (= errno DB_KEYEMPTY)) - nil) - ((or (= errno DB_LOCK_DEADLOCK) - (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno)))))) - -;; Transactions - -(def-function ("db_txn_begin" %db-txn-begin) - ((env :pointer-void) - (parent :pointer-void) - (flags :unsigned-int) - (errno (* :int))) - :returning :pointer-void) - -(defun db-transaction-begin (env &key (parent *current-transaction*) - dirty-read txn-nosync txn-nowait - txn-sync) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void env parent) - (type boolean dirty-read txn-nosync txn-nowait - txn-sync) - (type pointer-int *errno-buffer*)) - (let* ((txn - (%db-txn-begin env parent - (flags :dirty-read dirty-read - :txn-nosync txn-nosync - :txn-nowait txn-nowait - :txn-sync txn-sync) - *errno-buffer*)) - (errno (deref-array *errno-buffer* '(:array :int) 0))) - (declare (type pointer-void txn) - (type fixnum errno)) - (if (= errno 0) - txn - (error 'db-error :errno errno)))) - -(def-function ("db_txn_abort" %db-txn-abort) - ((txn :pointer-void)) - :returning :int) - -(wrap-errno (db-transaction-abort %db-txn-abort) (transaction) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void transaction))) - -(def-function ("db_txn_commit" %db-txn-commit) - ((txn :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags) - :keys ((transaction *current-transaction*)) - :flags (txn-nosync txn-sync) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void transaction) - (type boolean txn-nosync txn-sync))) - -(defmacro with-transaction ((&key transaction environment - (parent '*current-transaction*) - (retries 100) - dirty-read txn-nosync - txn-nowait txn-sync) - &body body) - (let ((txn (if transaction transaction (gensym))) - (count (gensym)) - (result (gensym)) - (success (gensym))) - `(loop for ,count fixnum from 1 to ,retries - for ,txn of-type pointer-void = - (db-transaction-begin ,environment - :parent ,parent - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) - for ,success of-type boolean = nil - for ,result = - (let ((*current-transaction* ,txn)) - (catch ,txn - (unwind-protect - (prog1 (progn , at body) - (setq ,success t) - (db-transaction-commit :transaction ,txn - :txn-nosync ,txn-nosync - :txn-sync ,txn-sync)) - (unless ,success - (db-transaction-abort :transaction ,txn))))) - do - (unless (and (eq ,result ,txn) (not ,success)) - (return ,result)) - finally (error "Too many retries")))) - -;; this is code for a non-consing with-transaction. which -;; doesn't work in the (globally t) case (e.g. setting -;; *current-transaction*.) - -; #+cmu -; `(alien:with-alien ((,txn (* t) -; (%db-txn-begin -; ,environment ,parent -; (flags :dirty-read ,dirty-read -; :txn-nosync ,txn-nosync -; :txn-nowait ,txn-nowait -; :txn-sync ,txn-sync) -; *errno-buffer*))) -; (let ((,success nil) -; ,@(if globally `((*current-transaction* ,txn)) (values))) -; (declare (type pointer-void *current-transaction*) -; (dynamic-extent *current-transaction*)) -; (unwind-protect -; (prog1 (progn , at body) -; (setq ,success t) -; (%db-txn-commit ,txn -; (flags :txn-nosync ,txn-nosync -; :txn-sync ,txn-sync))) -; (unless ,success (%db-txn-abort ,txn))))))) - - -;; Locks and timeouts - - -(def-enum DB-LOCKOP ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT - :PUT :PUT-ALL :PUT-OBJ :PUT-READ - :TIMEOUT :TRADE :UPGRADE-WRITE)) - -(def-enum DB-LOCKMODE ((:NG 0) :READ :WRITE :WAIT - :IWRITE :IREAD :IWR :DIRTY :WWRITE)) - -(def-struct DB-LOCK - (off :unsigned-int) - (ndx :unsigned-int) - (gen :unsigned-int) - (mode DB-LOCKMODE)) - -#+openmcl -(ccl:def-foreign-type DB-LOCK (:struct DB-LOCK)) - -(def-struct DB-LOCKREQ - (op DB-LOCKOP) - (mode DB-LOCKMODE) - (timeout :unsigned-int) - (obj (:array :char)) - (lock (* DB-LOCK))) - -#+openmcl -(ccl:def-foreign-type DB-LOCKREQ (:struct DB-LOCKREQ)) - -(def-function ("db_txn_id" %db-transaction-id) - ((transaction :pointer-void)) - :returning :unsigned-int) - -(defun db-transaction-id (&optional (transaction *current-transaction*)) - (%db-transaction-id transaction)) - -(def-function ("db_env_lock_id" %db-env-lock-id) - ((env :pointer-void) - (id :unsigned-int :out)) - :returning :int) - -(wrap-errno db-env-lock-id (env) :outs 2) - - -(def-function ("db_env_lock_id_free" %db-env-lock-id-free) - ((env :pointer-void) - (id :unsigned-int)) - :returning :int) - -(wrap-errno db-env-lock-id-free (env id)) - -(def-function ("db_env_lock_get" %db-env-lock-get) - ((env :pointer-void) - (locker :unsigned-int) - (flags :unsigned-int) - (object array-or-pointer-char) - (object-length :unsigned-int) - (lock-mode DB-LOCKMODE) - (lock (* DB-LOCK))) - :returning :int) - -(wrap-errno db-env-lock-get (env locker flags object object-length - lock-mode lock) - :flags (lock-nowait)) - -(def-function ("db_env_lock_put" %db-env-lock-put) - ((env :pointer-void) - (lock (* DB-LOCK))) - :returning :int) - -(wrap-errno db-env-lock-put (env lock)) - -(defmacro with-lock ((env locker object object-length - &key (lock-mode DB-LOCKMODE#WRITE) - lock-nowait) - &body body) - (let ((lock (gensym)) - (locked (gensym))) - `(with-foreign-object (,lock 'DB-LOCK) - (let ((,locked nil)) - (unwind-protect - (progn - (db-env-lock-get ,env ,locker ,object ,object-length ,lock-mode - ,lock :lock-nowait ,lock-nowait) - (setq ,locked T) - , at body) - (when ,locked (db-env-lock-put ,env ,lock))))))) - -(def-function ("db_env_lock_vec" %db-env-lock-vec) - ((env :pointer-void) - (locker :unsigned-int) - (flags :unsigned-int) - (list (:array DB-LOCKREQ)) - (nlist :int) - (elistp (* (* DB-LOCKREQ)))) - :returning :int) - -(def-function ("db_env_set_timeout" %db-env-set-timeout) - ((env :pointer-void) - (timeout :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-set-timeout (env timeout flags) - :flags (set-lock-timeout set-transaction-timeout)) - -(def-function ("db_env_get_timeout" %db-env-get-timeout) - ((env :pointer-void) - (timeout :unsigned-int :out) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-get-timeout (env flags) :outs 2 - :flags (set-lock-timeout set-transaction-timeout)) - -(defconstant DB_LOCK_DEFAULT 1) -(defconstant DB_LOCK_EXPIRE 2) -(defconstant DB_LOCK_MAXLOCKS 3) -(defconstant DB_LOCK_MINLOCKS 4) -(defconstant DB_LOCK_MINWRITE 5) -(defconstant DB_LOCK_OLDEST 6) -(defconstant DB_LOCK_RANDOM 7) -(defconstant DB_LOCK_YOUNGEST 8) - -(def-function ("db_env_set_lk_detect" %db-env-set-lock-detect) - ((env :pointer-void) - (detect :unsigned-int)) - :returning :int) - -(wrap-errno db-env-set-lock-detect (env detect)) - -(def-function ("db_env_get_lk_detect" %db-env-get-lock-detect) - ((env :pointer-void) - (detect :unsigned-int :out)) - :returning :int) - -(wrap-errno db-env-get-lock-detect (env) :outs 2) - -(def-function ("db_env_lock_detect" %db-env-lock-detect) - ((env :pointer-void) - (flags :unsigned-int) - (atype :unsigned-int) - (aborted :int :out)) - :returning :int) - -(wrap-errno db-env-lock-detect (env flags atype) :outs 2) - -;; Poor man's counters - -(def-function ("next_counter" %next-counter) - ((env :pointer-void) - (db :pointer-void) - (parent :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (lockid array-or-pointer-char) - (lockid-length :unsigned-int)) - :returning :int) -(defun next-counter (env db parent key key-length lockid lockid-length) - (let ((ret (%next-counter env db parent key key-length lockid lockid-length))) - (if (< ret 0) - (error 'db-error :errno ret) - ret))) - -;; Misc - -(defun flags (&key - auto-commit - joinenv - init-cdb - init-lock - init-log - init-mpool - init-rep - init-txn - recover - recover-fatal - lockdown - private - system-mem - thread - force - get-both - dirty-read - create - excl - nommap - rdonly - truncate - txn-nosync - txn-nowait - txn-sync - set-lock-timeout - set-transaction-timeout - lock-nowait) - (let ((flags 0)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type (unsigned-byte 32) flags) - (type boolean auto-commit joinenv init-cdb init-lock - init-log init-mpool init-rep init-txn - recover recover-fatal lockdown private - system-mem thread force get-both - dirty-read create excl nommap rdonly - truncate txn-nosync txn-nowait - set-lock-timeout set-transaction-timeout)) - (when auto-commit (setq flags (logior flags DB_AUTO_COMMIT))) - (when joinenv (setq flags (logior flags DB_JOINENV))) - (when init-cdb (setq flags (logior flags DB_INIT_CDB))) - (when init-lock (setq flags (logior flags DB_INIT_LOCK))) - (when init-log (setq flags (logior flags DB_INIT_LOG))) - (when init-mpool (setq flags (logior flags DB_INIT_MPOOL))) - (when init-rep (setq flags (logior flags DB_INIT_REP))) - (when init-txn (setq flags (logior flags DB_INIT_TXN))) - (when recover (setq flags (logior flags DB_RECOVER))) - (when recover-fatal (setq flags (logior flags DB_RECOVER_FATAL))) - (when lockdown (setq flags (logior flags DB_LOCKDOWN))) - (when private (setq flags (logior flags DB_PRIVATE))) - (when system-mem (setq flags (logior flags DB_SYSTEM_MEM))) - (when thread (setq flags (logior flags DB_THREAD))) - (when force (setq flags (logior flags DB_FORCE))) - (when get-both (setq flags (logior flags DB_GET_BOTH))) - (when dirty-read (setq flags (logior flags DB_DIRTY_READ))) - (when create (setq flags (logior flags DB_CREATE))) - (when excl (setq flags (logior flags DB_EXCL))) - (when nommap (setq flags (logior flags DB_NOMMAP))) - (when rdonly (setq flags (logior flags DB_RDONLY))) - (when truncate (setq flags (logior flags DB_TRUNCATE))) - (when txn-nosync (setq flags (logior flags DB_TXN_NOSYNC))) - (when txn-nowait (setq flags (logior flags DB_TXN_NOWAIT))) - (when txn-sync (setq flags (logior flags DB_TXN_SYNC))) - (when set-lock-timeout (setq flags (logior flags DB_SET_LOCK_TIMEOUT))) - (when set-transaction-timeout (setq flags (logior flags DB_SET_TXN_TIMEOUT))) - (when lock-nowait (setq flags (logior flags DB_LOCK_NOWAIT))) - flags)) - -;; Errors - -(def-function ("db_strerr" %db-strerror) - ((error :int)) - :returning :cstring) - -(defun db-strerror (errno) - (convert-from-cstring (%db-strerror errno))) - -(define-condition db-error (error) - ((errno :type fixnum :initarg :errno :reader db-error-errno)) - (:report - (lambda (condition stream) - (declare (type db-error condition) (type stream stream)) - (format stream "Berkeley DB error: ~A" - (db-strerror (db-error-errno condition)))))) From blee at common-lisp.net Sun Sep 19 17:36:24 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:36:24 +0200 Subject: [elephant-cvs] CVS update: elephant/CREDITS Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24311 Modified Files: CREDITS Log Message: updates Date: Sun Sep 19 19:36:23 2004 Author: blee Index: elephant/CREDITS diff -u elephant/CREDITS:1.2 elephant/CREDITS:1.3 --- elephant/CREDITS:1.2 Tue Aug 31 01:46:12 2004 +++ elephant/CREDITS Sun Sep 19 19:36:22 2004 @@ -6,13 +6,16 @@ Thanks to: -Sleepycat for Berkeley DB +Sleepycat for Berkeley DB, especially Ron Cohen and Michael +Cahill for answering my questions Kevin Rosenberg for UFFI, answering lots of questions and letting me patch Gary Byers for OpenMCL and answering my questions +Richard Waters (and Paul Dietz, Kevin Rosenberg) for RT + Rafal Strzalinski for the Makefile and package patch The common-lisp.net people for hosting @@ -22,6 +25,10 @@ SLIME for a better environment Erik Enge (CL-IRC) for being an unwitting guinea pig + +Dan Barlow for ASDF + +IBM for ICU Paul Foley for his berkeley-db package (which we didn't use, once we settled on UFFI) From blee at common-lisp.net Sun Sep 19 17:37:03 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:37:03 +0200 Subject: [elephant-cvs] CVS update: elephant/INSTALL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24408 Modified Files: INSTALL Log Message: updates Date: Sun Sep 19 19:37:03 2004 Author: blee Index: elephant/INSTALL diff -u elephant/INSTALL:1.8 elephant/INSTALL:1.9 --- elephant/INSTALL:1.8 Thu Sep 2 17:19:17 2004 +++ elephant/INSTALL Sun Sep 19 19:37:03 2004 @@ -3,8 +3,8 @@ Requirements ------------ -CMUCL 19a, SBCL 0.8.13, OpemMCL 0.14.2, or Allegro CL 6.2. -I've tested under FreeBSD, Linux and OpenMCL / Darwin. A +CMUCL 19a, SBCL 0.8.14, OpemMCL 0.14.2, or Allegro CL 6.2. +I've tested under x86 FreeBSD, Linux and PPC Darwin. A Lispworks version will come if requested. ASDF - http://www.cliki.net/asdf @@ -55,7 +55,7 @@ This compiles src/libsleepycat.c and installs it into -/usr/local/share/common-lisp/elephant/ +/usr/local/share/common-lisp/elephant-0.2/ or where you specified. On Darwin / OS X you need to have the developer tools installed. @@ -72,9 +72,7 @@ (asdf:operate 'asdf:load-op :elephant) This will load and compile Elephant. This will also -automatically load UFFI. You may get "constant redefinition -errors", especially on SBCL. They are not issues, go ahead -and redefine the constants. +automatically load UFFI. I can't seem to make OpenMCL not intern default keyword values of my macros -- something which doesn't happen on @@ -160,3 +158,24 @@ NIL CL-USER> + +------- +Testing +------- + +Elephant uses RT for regression testing, available at: + +http://www.cliki.net/RT + +Once RT is installed, edit tests/elephant-tests.lisp to make +*testdb-path* point to somewhere appropriate. Symlink +elephant-tests.asd to your asdf systems directory, then run + +(asdf:operate 'asdf:load-op :elephant-tests) +(in-package :ele-tests) +(do-all-tests) + +this should take about 5 minutes on decent hardware. Note +that the "no-eval-initform" test fails, this is a known bug +which will get fixed in a future release. + From blee at common-lisp.net Sun Sep 19 17:37:25 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:37:25 +0200 Subject: [elephant-cvs] CVS update: elephant/LICENSE Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24435 Modified Files: LICENSE Log Message: added ICU license bit Date: Sun Sep 19 19:37:25 2004 Author: blee Index: elephant/LICENSE diff -u elephant/LICENSE:1.2 elephant/LICENSE:1.3 --- elephant/LICENSE:1.2 Sun Aug 29 22:32:18 2004 +++ elephant/LICENSE Sun Sep 19 19:37:25 2004 @@ -7,6 +7,12 @@ ("GPL"). For differenct licensing terms, contact the copyright holders. +Portions of this program (namely the C unicode string +sorter) are derived from IBM's ICU: + +http://oss.software.ibm.com/icu/ + +whose copyright and license follows the GPL below. The GNU General Public License (GPL) Version 2, June 1991 @@ -330,4 +336,46 @@ HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. -END OF TERMS AND CONDITIONS \ No newline at end of file +END OF TERMS AND CONDITIONS + + + +ICU License - ICU 1.8.1 and later +COPYRIGHT AND PERMISSION NOTICE + +Copyright (c) 1995-2003 International Business Machines +Corporation and others All rights reserved. + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated +documentation files (the "Software"), to deal in the +Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, +and/or sell copies of the Software, and to permit persons to +whom the Software is furnished to do so, provided that the +above copyright notice(s) and this permission notice appear +in all copies of the Software and that both the above +copyright notice(s) and this permission notice appear in +supporting documentation. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY +KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR +PURPOSE AND NONINFRINGEMENT OF THIRD PARTY RIGHTS. IN NO +EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS +NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR +CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING +FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF +CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT +OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +Except as contained in this notice, the name of a copyright +holder shall not be used in advertising or otherwise to +promote the sale, use or other dealings in this Software +without prior written authorization of the copyright holder. + +------------------------------------------------------------ +All trademarks and registered trademarks mentioned herein +are the property of their respective owners. + From blee at common-lisp.net Sun Sep 19 17:38:27 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:38:27 +0200 Subject: [elephant-cvs] CVS update: elephant/NEWS Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv25357 Modified Files: NEWS Log Message: updates for release Date: Sun Sep 19 19:38:26 2004 Author: blee Index: elephant/NEWS diff -u elephant/NEWS:1.4 elephant/NEWS:1.5 --- elephant/NEWS:1.4 Thu Sep 2 17:11:58 2004 +++ elephant/NEWS Sun Sep 19 19:38:25 2004 @@ -1,4 +1,20 @@ +September 19, 2004 - + +Elephant 0.2 released. This is an BETA release. + +New features: + +- Secondary indices and cursors +- PPC Darwin OpenMCL / SBCL +- Doc strings and improved documentation +- An RT-based test suite +- many bugfixes + +This release has been tested on CMUCL 19a, SBCL 0.8.14 and +Allegro 6.2 on x86 Linux and FreeBSD, and OpenMCL 0.14.2-p1 +and SBCL 0.8.14 on PPC Darwin. + September 2, 2004 - The bad news: there was a bug in 0.1 which made OID From blee at common-lisp.net Sun Sep 19 17:39:59 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:39:59 +0200 Subject: [elephant-cvs] CVS update: elephant/NOTES Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv26826 Modified Files: NOTES Log Message: updates Date: Sun Sep 19 19:39:59 2004 Author: blee Index: elephant/NOTES diff -u elephant/NOTES:1.4 elephant/NOTES:1.5 --- elephant/NOTES:1.4 Mon Aug 30 23:37:36 2004 +++ elephant/NOTES Sun Sep 19 19:39:59 2004 @@ -3,10 +3,10 @@ GENERAL ------- -this has been optimized for use with CMUCL. it has been -tested and somewhat optimized for allegro. SBCL and OpenMCL -are definitely also desired targets. Lispworks is a target -as well but less so: i don't have access to it. +this has been optimized for use with CMUCL / SBCL. it has +been tested and somewhat optimized for allegro. OpenMCL is +definitely also a target. Lispworks is a target as well but +less so: i don't have access to it. Theoretically one can port this to any lisp with a decent FFI and MOP. However since those are two of the less @@ -46,6 +46,10 @@ slot-boundp-using-class inside of shared-initialize, which necessitates some work. +CMUCL doesn't do non-standard allocation types correctly, so +we've created our own slot definition keyword :transient. +In the future this will change. + Andrew will add some notes here in the future. ----------- @@ -89,8 +93,25 @@ over ordinary hash-tables from the point of view of persistence. -TODO: programmatic way to create secondary indicies -(probably Lisp-level, since FFI callbacks are nasty.) +There is a separate table for BTrees. This is because we +use a hand coded C function for sorting, which understands a +little of the serialized data. It can handle numbers (up to +64-bit bignums -- they are approximated by floats) and +strings (case-insensitive for 8-bit, code-point-order for +16-bit Unicode.) It should be fast but we don't want a +performance penalty on objects. + +Secondary indices are mostly handled on the lisp side, +because of our weird table layout (see below) and to avoid +crossing FFI boundaries. Some unscientific microbenchmarks +indicated that there was no performance benefit on CMUCL / +SBCL, and only minor benefit (asymptotically nil) on +OpenMCL. They have a separate table. Actually two handles +are opened on this table: one which is plain, and one which +is associated to the primary btree table by a no-op indexing +function. Since we maintain the secondary keys ourselves, +the associated handle is good for gets / cursor traversals. +We use the unassociated handle for updates. ---------- CONTROLLER @@ -142,13 +163,15 @@ OID + Slot ID -Collections use +Collections use 2 tables, one for primaries and one for +secondaries (which supports duplicates.) They are keyed on OID + key -the root object is a btree with OID = 0. Since keys are +The root object is a btree with OID = 0. Since keys are lexicographically ordered, this will create cache locality -for items in the same persistent object / collection. +for items in the same persistent object / collection. We +use a custom C sorter for the btree tables. Other layout options: @@ -214,7 +237,7 @@ CMUCL's consing dpb/ldb arithmetic means serializing bignums conses (but they shouldn't have to!) Serializing everything else should not cons (with the exception of maybe symbols -and pathnames.) +and pathnames.) SBCL seems much better with this. Deserialization of fixnums is non-consing. floats appear to cons on CMUCL, i'm not sure if this is just because of @@ -300,15 +323,17 @@ pointer-arithmetic is bignum and therefore consing. TODO: write faster, lispier versions of the -pointer-arithmetic functions. (Definitely possible under -OpenMCL; maybe possible using SAP arithmetic under CMUCL. -Dunno about Allegro, Lispworks.) +pointer-arithmetic functions. This is done for CMUCL / +SBCL. (Definitely possible under OpenMCL. Dunno about +Allegro, Lispworks.) CMUCL et al can't do dynamic-extent buffers, so we use globals bound to specials, which should be thread-safe if properly initialized. While we provide functions talk to -the DB using strings, Elephant itself only uses foreign char -buffers. +the DB using strings, Elephant itself only uses +"buffer-streams", which are structures which have a +stream-like interface to foreign char buffers for reading / +writing C datatypes. Lispworks is much happier passing back and forth statically allocated lisp arrays. since the general string will almost From blee at common-lisp.net Sun Sep 19 17:40:30 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:40:30 +0200 Subject: [elephant-cvs] CVS update: elephant/README Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv26856 Modified Files: README Log Message: updates Date: Sun Sep 19 19:40:29 2004 Author: blee Index: elephant/README diff -u elephant/README:1.3 elephant/README:1.4 --- elephant/README:1.3 Tue Aug 31 01:46:12 2004 +++ elephant/README Sun Sep 19 19:40:29 2004 @@ -40,17 +40,23 @@ http://www.common-lisp.net/project/elephant ------------------- -License + Warrenty ------------------- +----------------------------- +Copyright, License + Warrenty +----------------------------- See LICENSE. +------------ +Installation +------------ + +See INSTALL + ---------------------- -Installation and Usage +Tutorial and Reference ---------------------- -See INSTALL and TUTORIAL. +HTML docs and texinfo sources can be found in the docs/ directory. ------ Design From blee at common-lisp.net Sun Sep 19 17:41:43 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:41:43 +0200 Subject: [elephant-cvs] CVS update: elephant/TODO Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv26883 Modified Files: TODO Log Message: updates Date: Sun Sep 19 19:41:43 2004 Author: blee Index: elephant/TODO diff -u elephant/TODO:1.5 elephant/TODO:1.6 --- elephant/TODO:1.5 Thu Sep 16 06:11:21 2004 +++ elephant/TODO Sun Sep 19 19:41:43 2004 @@ -8,35 +8,23 @@ tweak performance of transactions! dynamic-extent in CMUCL / SBCL. -more documentation: reference! +more documentation: texinfo NOTES. -secondary index generation, cursors: - -- secondary indices on the "lisp" side : minor / nil -performance gains and DB handle badness for DB->associate - -- create 2 DBs per sorting function: primary and secondary, -without and with duplicates. - -- in addition to the usual lexicographic sorter, create a -"lisp" version -- sorts primitive types (numbers, strings, -symbols.) use http://oss.software.ibm.com/icu/ for 16-bit -unicode. - -- equality joins have to be done on the lisp side: +equality joins have to be done on the lisp side: end-of-table is not the same as end-of-btree. GC (need cursors) Lispworks stuff (fli:replace-foreign-array...) -bignum fix: CMUCL / SBCL use %bignum-ref. OpenMCL: check -that ldb is non-consing (i think it is), look at -%ldb-fixnum-from-bignum) +bignum fix: OpenMCL: check that ldb is non-consing (i think +it is), look at %ldb-fixnum-from-bignum. profile +%bignum-ref on CMUCL / SBCL. serialize lambdas, closures, packages.....this is hard! -lispy pointer arithmetic (profile sap-alien, etc) +openmcl lispy pointer arithmetic (profile sap-alien, etc). +profile CMUCL / SBCL sap arithmetic. performance hacks: class / slot to ID @@ -53,4 +41,6 @@ incorporate requirements from ICU license -cursor-put : move the cursor after insert. \ No newline at end of file +cursor-put : move the cursor after insert. + +change :transient flag to an allocation type (fix CMUCL!) \ No newline at end of file From blee at common-lisp.net Sun Sep 19 17:41:51 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:41:51 +0200 Subject: [elephant-cvs] CVS update: Directory change: elephant/doc Message-ID: Update of /project/elephant/cvsroot/elephant/doc In directory common-lisp.net:/tmp/cvs-serv26905/doc Log Message: Directory /project/elephant/cvsroot/elephant/doc added to the repository Date: Sun Sep 19 19:41:51 2004 Author: blee New directory elephant/doc added From blee at common-lisp.net Sun Sep 19 17:44:51 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:44:51 +0200 Subject: [elephant-cvs] CVS update: elephant/doc/tutorial.texinfo elephant/doc/reference.texinfo elephant/doc/package-elephant.texinfo elephant/doc/notes.texinfo elephant/doc/make-ref.lisp elephant/doc/intro.texinfo elephant/doc/elephant.texinfo elephant/doc/docstrings.lisp elephant/doc/cvs2cl.pl elephant/doc/copying.texinfo Message-ID: Update of /project/elephant/cvsroot/elephant/doc In directory common-lisp.net:/tmp/cvs-serv26988/doc Added Files: tutorial.texinfo reference.texinfo package-elephant.texinfo notes.texinfo make-ref.lisp intro.texinfo elephant.texinfo docstrings.lisp cvs2cl.pl copying.texinfo Log Message: first version of texinfo docs, automagic changelog Date: Sun Sep 19 19:44:43 2004 Author: blee From blee at common-lisp.net Sun Sep 19 17:47:00 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:47:00 +0200 Subject: [elephant-cvs] CVS update: elephant/src/berkeley-db.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv27751/src Modified Files: berkeley-db.lisp Log Message: docstring fix Date: Sun Sep 19 19:46:57 2004 Author: blee Index: elephant/src/berkeley-db.lisp diff -u elephant/src/berkeley-db.lisp:1.1 elephant/src/berkeley-db.lisp:1.2 --- elephant/src/berkeley-db.lisp:1.1 Thu Sep 16 06:19:57 2004 +++ elephant/src/berkeley-db.lisp Sun Sep 19 19:46:56 2004 @@ -1370,5 +1370,5 @@ (lambda (condition stream) (declare (type db-error condition) (type stream stream)) (format stream "Berkeley DB error: ~A" - (db-strerror (db-error-errno condition)))) - :documentation "Berkeley DB / Sleepycat errors.")) + (db-strerror (db-error-errno condition))))) + (:documentation "Berkeley DB / Sleepycat errors.")) From blee at common-lisp.net Sun Sep 19 17:47:48 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:47:48 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv27847/src Modified Files: classes.lisp Log Message: docstring fix Date: Sun Sep 19 19:47:45 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.10 elephant/src/classes.lisp:1.11 --- elephant/src/classes.lisp:1.10 Thu Sep 16 06:14:04 2004 +++ elephant/src/classes.lisp Sun Sep 19 19:47:44 2004 @@ -55,9 +55,10 @@ (defclass persistent-object (persistent) ((%persistent-slots :transient t)) - (:documentation "Superclass of all user-defined persistent -classes. To make some slots not persisted, use the -:transient flag.") + (:documentation +"Superclass of all user-defined persistent classes. This is +automatically inherited if you use the persistent-metaclass +metaclass.") (:metaclass persistent-metaclass)) (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) From blee at common-lisp.net Sun Sep 19 17:48:14 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:48:14 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv27914/src Modified Files: collections.lisp Log Message: docstring fix Date: Sun Sep 19 19:48:12 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.7 elephant/src/collections.lisp:1.8 --- elephant/src/collections.lisp:1.7 Thu Sep 16 06:14:44 2004 +++ elephant/src/collections.lisp Sun Sep 19 19:48:11 2004 @@ -52,15 +52,19 @@ (:documentation "A hash-table like interface to a BTree, which stores things in a semi-ordered fashion.")) -(defgeneric get-value (key ht)) -(defgeneric (setf get-value) (value key ht)) -(defgeneric remove-kv (key ht)) +(defgeneric get-value (key bt) + (:documentation "Get a value from a Btree.")) -(defmethod get-value (key (ht btree)) - "Get a value from a Btree." +(defgeneric (setf get-value) (value key bt) + (:documentation "Put a key / value pair into a BTree.")) + +(defgeneric remove-kv (key bt) + (:documentation "Remove a key / value pair from a BTree.")) + +(defmethod get-value (key (bt btree)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid ht) key-buf) + (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered (controller-btrees *store-controller*) @@ -68,11 +72,10 @@ (if buf (values (deserialize buf) T) (values nil nil))))) -(defmethod (setf get-value) (value key (ht btree)) - "Put a key / value pair into a BTree." +(defmethod (setf get-value) (value key (bt btree)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid ht) key-buf) + (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (serialize value value-buf) (db-put-buffered (controller-btrees *store-controller*) @@ -80,11 +83,10 @@ :auto-commit *auto-commit*) value)) -(defmethod remove-kv (key (ht btree)) - "Remove a key / value pair from a BTree." +(defmethod remove-kv (key (bt btree)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf) - (buffer-write-int (oid ht) key-buf) + (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (db-delete-buffered (controller-btrees *store-controller*) key-buf :auto-commit *auto-commit*))) @@ -104,47 +106,72 @@ (declare (ignore slot-names rest)) (setf (indices-cache instance) (indices instance))) -(defgeneric add-index (ht &key index-name key-form)) -(defgeneric get-index (ht index-name)) -(defgeneric remove-index (ht index-name)) - -(defmethod add-index ((ht indexed-btree) &key index-name key-form) - "Add a secondary index. The indices are stored in an eq +(defgeneric add-index (bt &key index-name key-form) + (:documentation + "Add a secondary index. The indices are stored in an eq hash-table, so the index-name should be a symbol. key-form should be a symbol naming a function, or a list which defines a lambda -- actual functions aren't supported. The function should take 3 arguments: the secondary DB, primary key and value, and return two values: a boolean indicating whether to index this key / value, and the secondary key if -so." +so. If populate = t it will fill in secondary keys for +existing primary entries (may be expensive!)")) + +(defgeneric get-index (bt index-name) + (:documentation "Get a named index.")) + +(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 ht)) - (index (make-instance 'btree-index :primary ht + (let ((indices (indices bt)) + (index (make-instance 'btree-index :primary bt :key-form key-form))) - (setf (gethash index-name (indices-cache ht)) index) + (setf (gethash index-name (indices-cache bt)) index) (setf (gethash index-name indices) index) - (setf (indices ht) indices) + (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 get-index ((ht indexed-btree) index-name) - "Get a named index." - (gethash index-name (indices-cache ht))) - -(defmethod remove-index ((ht indexed-btree) index-name) - "Remove a named index." - (remhash index-name (indices-cache ht)) - (let ((indices (indices ht))) +(defmethod get-index ((bt indexed-btree) index-name) + (gethash index-name (indices-cache bt))) + +(defmethod remove-index ((bt indexed-btree) index-name) + (remhash index-name (indices-cache bt)) + (let ((indices (indices bt))) (remhash index-name indices) - (setf (indices ht) indices))) + (setf (indices bt) indices))) -(defmethod (setf get-value) (value key (ht indexed-btree)) +(defmethod (setf get-value) (value key (bt indexed-btree)) "Set a key / value pair, and update secondary indices." (declare (optimize (speed 3))) - (let ((indices (indices-cache ht))) + (let ((indices (indices-cache bt))) (with-buffer-streams (key-buf value-buf secondary-buf) - (buffer-write-int (oid ht) key-buf) + (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (serialize value value-buf) (with-transaction () @@ -164,16 +191,16 @@ (reset-buffer-stream secondary-buf)))) value)))) -(defmethod remove-kv (key (ht indexed-btree)) +(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 ht) key-buf) + (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (with-transaction () - (let ((value (get-value key ht))) + (let ((value (get-value key bt))) (when value - (let ((indices (indices-cache ht))) + (let ((indices (indices-cache bt))) (loop for index being the hash-value of indices do @@ -206,11 +233,11 @@ (setf (key-fn instance) (fdefinition key-form)) (setf (key-fn instance) (compile nil key-form))))) -(defmethod get-value (key (ht btree-index)) +(defmethod get-value (key (bt 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 ht) key-buf) + (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered (controller-indices-assoc *store-controller*) @@ -218,19 +245,19 @@ (if buf (values (deserialize buf) T) (values nil nil))))) -(defmethod (setf get-value) (value key (ht btree-index)) +(defmethod (setf get-value) (value key (bt btree-index)) "Puts are not allowed on secondary indices. Try adding to the primary." - (declare (ignore value key ht)) + (declare (ignore value key bt)) (error "Puts are forbidden on secondary indices. Try adding to the primary.")) -(defgeneric get-primary-key (key ht)) +(defgeneric get-primary-key (key bt) + (:documentation "Get the primary key from a secondary key.")) -(defmethod get-primary-key (key (ht btree-index)) - "Get the primary key from a secondary key." +(defmethod get-primary-key (key (bt btree-index)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid ht) key-buf) + (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered (controller-indices *store-controller*) @@ -240,10 +267,11 @@ (values (deserialize buf) oid)) (values nil nil))))) -(defmethod remove-kv (key (ht btree-index)) - "Remove a key / value, updating ALL secondary indices." +(defmethod remove-kv (key (bt btree-index)) + "Remove a key / value from the PRIMARY by a secondary +lookup, updating ALL other secondary indices." (declare (optimize (speed 3))) - (remove-kv (get-primary-key key ht) (primary ht))) + (remove-kv (get-primary-key key bt) (primary bt))) ;; Cursor operations @@ -256,33 +284,86 @@ (btree :accessor cursor-btree :initarg :btree)) (:documentation "A cursor for traversing (primary) BTrees.")) -(defgeneric make-cursor (ht)) -(defgeneric cursor-close (cursor)) -(defgeneric cursor-duplicate (cursor)) -(defgeneric cursor-current (cursor)) -(defgeneric cursor-first (cursor)) -(defgeneric cursor-last (cursor)) -(defgeneric cursor-next (cursor)) -(defgeneric cursor-prev (cursor)) -(defgeneric cursor-set (cursor key)) -(defgeneric cursor-set-range (cursor key)) -(defgeneric cursor-get-both (cursor key value)) -(defgeneric cursor-get-both-range (cursor key value)) -(defgeneric cursor-delete (cursor)) -(defgeneric cursor-put (cursor value &key key)) +(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 +enclosing transaction is closed!")) + +(defgeneric cursor-duplicate (cursor) + (:documentation "Duplicate a cursor.")) + +(defgeneric cursor-current (cursor) + (:documentation + "Get the key / value at the cursor position. Returns +has-pair key value, where has-pair is a boolean indicating +there was a pair.")) + +(defgeneric cursor-first (cursor) + (:documentation + "Move the cursor to the beginning of the BTree, returning +has-pair key value.")) + +(defgeneric cursor-last (cursor) + (:documentation + "Move the cursor to the end of the BTree, returning +has-pair key value.")) + +(defgeneric cursor-next (cursor) + (:documentation + "Advance the cursor, returning has-pair key value.")) + +(defgeneric cursor-prev (cursor) + (:documentation + "Move the cursor back, returning has-pair key value.")) + +(defgeneric cursor-set (cursor key) + (:documentation + "Move the cursor to a particular key, returning has-pair +key value.")) + +(defgeneric cursor-set-range (cursor key) + (:documentation + "Move the cursor to the first key-value pair with key +greater or equal to the key argument, according to the lisp +sorter. Returns has-pair key value.")) + +(defgeneric cursor-get-both (cursor key value) + (:documentation + "Moves the cursor to a particular key / value pair, +returning has-pair key value.")) + +(defgeneric cursor-get-both-range (cursor key value) + (:documentation + "Moves the cursor to the first key / value pair with key +equal to the key argument and value greater or equal to the +value argument. Not really useful for us since primaries +don't have duplicates. Returns has-pair key value.")) + +(defgeneric cursor-delete (cursor) + (:documentation + "Delete by cursor. The cursor is at an invalid position +after a successful delete.")) + +(defgeneric cursor-put (cursor value &key key) + (:documentation + "Put by cursor. Currently doesn't properly move the +cursor.")) -(defmethod make-cursor ((ht btree)) - "Construct a cursor for traversing primary BTrees." +(defmethod make-cursor ((bt btree)) + "Make a cursor from a btree." (declare (optimize (speed 3))) (make-instance 'cursor - :btree ht + :btree bt :handle (db-cursor (controller-btrees *store-controller*)) - :oid (oid ht))) + :oid (oid bt))) -(defmacro with-btree-cursor ((var ht) &body body) +(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." - `(let ((,var (make-cursor ,ht))) + `(let ((,var (make-cursor ,bt))) (unwind-protect (progn , at body) (cursor-close ,var)))) @@ -296,14 +377,11 @@ (funcall fn k v))))) (defmethod cursor-close ((cursor cursor)) - "Close the cursor. Make sure to close cursors before the -enclosing transaction is closed!" (declare (optimize (speed 3))) (db-cursor-close (cursor-handle cursor)) (setf (cursor-initialized-p cursor) nil)) (defmethod cursor-duplicate ((cursor cursor)) - "Duplicate a cursor." (declare (optimize (speed 3))) (make-instance (type-of cursor) :initialized-p (cursor-initialized-p cursor) @@ -313,9 +391,6 @@ :position (cursor-initialized-p cursor)))) (defmethod cursor-current ((cursor cursor)) - "Get the key / value at the cursor position. Returns -has-pair key value, where has-pair is a boolean indicating -there was a pair." (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -328,8 +403,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-first ((cursor cursor)) - "Move the cursor to the beginning of the BTree, returning -has-pair key value." (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -343,8 +416,6 @@ ;;A bit of a hack..... (defmethod cursor-last ((cursor cursor)) - "Move the cursor to the end of the BTree, returning -has-pair key value." (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) @@ -370,7 +441,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-next ((cursor cursor)) - "Advance the cursor, returning has-pair key value." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -383,7 +453,6 @@ (cursor-first cursor))) (defmethod cursor-prev ((cursor cursor)) - "Move the cursor back, returning has-pair key value." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -396,8 +465,6 @@ (cursor-last cursor))) (defmethod cursor-set ((cursor cursor) key) - "Move the cursor to a particular key, returning has-pair -key value." (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -411,9 +478,6 @@ (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-set-range ((cursor cursor) key) - "Move the cursor to the first key-value pair with key -greater or equal to the key argument, according to the lisp -sorter. Returns has-pair key value." (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -427,8 +491,6 @@ (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-get-both ((cursor cursor) key value) - "Moves the cursor to a particular key / value pair, -returning has-pair key value." (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -444,10 +506,6 @@ (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-get-both-range ((cursor cursor) key value) - "Moves the cursor to the first key / value pair with key -equal to the key argument and value greater or equal to the -value argument. Not really useful for us since primaries -don't have duplicates. Returns has-pair key value." (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -462,8 +520,6 @@ (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-delete ((cursor cursor)) - "Delete by cursor. The cursor is at an invalid position -after a successful delete." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -502,34 +558,97 @@ (defclass secondary-cursor (cursor) () (:documentation "Cursor for traversing secondary indices.")) -(defgeneric cursor-pcurrent (cursor)) -(defgeneric cursor-pfirst (cursor)) -(defgeneric cursor-plast (cursor)) -(defgeneric cursor-pnext (cursor)) -(defgeneric cursor-pprev (cursor)) -(defgeneric cursor-pset (cursor key)) -(defgeneric cursor-pset-range (cursor key)) -(defgeneric cursor-pget-both (cursor key value)) -(defgeneric cursor-pget-both-range (cursor key value)) -(defgeneric cursor-next-dup (cursor)) -(defgeneric cursor-next-nodup (cursor)) -(defgeneric cursor-prev-nodup (cursor)) -(defgeneric cursor-pnext-dup (cursor)) -(defgeneric cursor-pnext-nodup (cursor)) -(defgeneric cursor-pprev-nodup (cursor)) +(defgeneric cursor-pcurrent (cursor) + (:documentation + "Returns has-tuple / secondary key / value / primary key +at the current position.")) + +(defgeneric cursor-pfirst (cursor) + (:documentation + "Moves the key to the beginning of the secondary index. +Returns has-tuple / secondary key / value / primary key.")) + +(defgeneric cursor-plast (cursor) + (:documentation + "Moves the key to the end of the secondary index. Returns +has-tuple / secondary key / value / primary key.")) + +(defgeneric cursor-pnext (cursor) + (:documentation + "Advances the cursor. Returns has-tuple / secondary key / +value / primary key.")) + +(defgeneric cursor-pprev (cursor) + (:documentation + "Moves the cursor back. Returns has-tuple / secondary key +/ value / primary key.")) -(defmethod make-cursor ((ht btree-index)) +(defgeneric cursor-pset (cursor key) + (:documentation + "Moves the cursor to a particular key. Returns has-tuple +/ secondary key / value / primary key.")) + +(defgeneric cursor-pset-range (cursor key) + (:documentation + "Move the cursor to the first key-value pair with key +greater or equal to the key argument, according to the lisp +sorter. Returns has-pair secondary key value primary key.")) + +(defgeneric cursor-pget-both (cursor key value) + (:documentation + "Moves the cursor to a particular secondary key / primary +key pair. Returns has-tuple / secondary key / value / +primary key.")) + +(defgeneric cursor-pget-both-range (cursor key value) + (:documentation + "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.")) + +(defgeneric cursor-next-dup (cursor) + (:documentation + "Move to the next duplicate element (with the same key.) +Returns has-pair key value.")) + +(defgeneric cursor-next-nodup (cursor) + (:documentation + "Move to the next non-duplicate element (with different +key.) Returns has-pair key value.")) + +(defgeneric cursor-prev-nodup (cursor) + (:documentation + "Move to the previous non-duplicate element (with +different key.) Returns has-pair key value.")) + +(defgeneric cursor-pnext-dup (cursor) + (:documentation + "Move to the next duplicate element (with the same key.) +Returns has-tuple / secondary key / value / primary key.")) + +(defgeneric cursor-pnext-nodup (cursor) + (:documentation + "Move to the next non-duplicate element (with different +key.) Returns has-tuple / secondary key / value / primary +key.")) + +(defgeneric cursor-pprev-nodup (cursor) + (:documentation + "Move to the previous non-duplicate element (with +different key.) Returns has-tuple / secondary key / value / +primary key.")) + +(defmethod make-cursor ((bt btree-index)) "Make a secondary-cursor from a secondary index." (declare (optimize (speed 3))) (make-instance 'secondary-cursor - :btree ht + :btree bt :handle (db-cursor (controller-indices-assoc *store-controller*)) - :oid (oid ht))) + :oid (oid bt))) (defmethod cursor-pcurrent ((cursor secondary-cursor)) - "Returns has-tuple / secondary key / value / primary key -at the current position." (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -544,8 +663,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pfirst ((cursor secondary-cursor)) - "Moves the key to the beginning of the secondary index. -Returns has-tuple / secondary key / value / primary key." (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -560,8 +677,6 @@ ;;A bit of a hack..... (defmethod cursor-plast ((cursor secondary-cursor)) - "Moves the key to the end of the secondary index. Returns -has-tuple / secondary key / value / primary key." (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) @@ -590,8 +705,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pnext ((cursor secondary-cursor)) - "Advances the cursor. Returns has-tuple / secondary key / -value / primary key." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -605,8 +718,6 @@ (cursor-pfirst cursor))) (defmethod cursor-pprev ((cursor secondary-cursor)) - "Moves the cursor back. Returns has-tuple / secondary key -/ value / primary key." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -620,8 +731,6 @@ (cursor-plast cursor))) (defmethod cursor-pset ((cursor secondary-cursor) key) - "Moves the cursor to a particular key. Returns has-tuple -/ secondary key / value / primary key." (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -636,9 +745,6 @@ (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-pset-range ((cursor secondary-cursor) key) - "Move the cursor to the first key-value pair with key -greater or equal to the key argument, according to the lisp -sorter. Returns has-pair secondary key value primary key." (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -653,9 +759,6 @@ (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-pget-both ((cursor secondary-cursor) key pkey) - "Moves the cursor to a particular secondary key / primary -key pair. Returns has-tuple / secondary key / value / -primary key." (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor))))) @@ -673,10 +776,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pget-both-range ((cursor secondary-cursor) key pkey) - "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." (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor))))) @@ -729,8 +828,6 @@ (error "Puts are forbidden on secondary indices. Try adding to the primary.")) (defmethod cursor-next-dup ((cursor secondary-cursor)) - "Move to the next duplicate element (with the same key.) -Returns has-pair key value." (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -742,8 +839,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-next-nodup ((cursor secondary-cursor)) - "Move to the next non-duplicate element (with different -key.) Returns has-pair key value." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -756,8 +851,6 @@ (cursor-first cursor))) (defmethod cursor-prev-nodup ((cursor secondary-cursor)) - "Move to the previous non-duplicate element (with -different key.) Returns has-pair key value." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -770,8 +863,6 @@ (cursor-last cursor))) (defmethod cursor-pnext-dup ((cursor secondary-cursor)) - "Move to the next duplicate element (with the same key.) -Returns has-tuple / secondary key / value / primary key." (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -784,9 +875,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pnext-nodup ((cursor secondary-cursor)) - "Move to the next non-duplicate element (with different -key.) Returns has-tuple / secondary key / value / primary -key." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -800,9 +888,6 @@ (cursor-pfirst cursor))) (defmethod cursor-pprev-nodup ((cursor secondary-cursor)) - "Move to the previous non-duplicate element (with -different key.) Returns has-tuple / secondary key / value / -primary key." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) From blee at common-lisp.net Sun Sep 19 17:49:26 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:49:26 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv28007/src Modified Files: controller.lisp Log Message: docstring fix, some easy transaction functions Date: Sun Sep 19 19:49:25 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.10 elephant/src/controller.lisp:1.11 --- elephant/src/controller.lisp:1.10 Thu Sep 16 06:15:31 2004 +++ elephant/src/controller.lisp Sun Sep 19 19:49:25 2004 @@ -61,38 +61,47 @@ creation, counters, locks, the root (for garbage collection,) et cetera.")) -(defgeneric cache-instance (sc obj)) -(defgeneric get-cached-instance (sc oid class-name)) -(defgeneric next-oid (sc)) -(defgeneric open-controller (sc &key recover recover-fatal thread)) -(defgeneric close-controller (sc)) +(defgeneric open-controller (sc &key recover recover-fatal thread) + (:documentation + "Opens the underlying environment and all the necessary +database tables.")) + +(defgeneric close-controller (sc) + (:documentation + "Close the db handles and environment. Tries to wipe out +references to the db handles.")) (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 everything it points to) won't get gc'd." + (declare (type store-controller store-controller)) (setf (get-value key (controller-root store-controller)) value)) (defun get-from-root (key &key (store-controller *store-controller*)) "Get a something from the root." + (declare (type store-controller store-controller)) (get-value key (controller-root store-controller))) (defun remove-from-root (key &key (store-controller *store-controller*)) "Remove something from the root." + (declare (type store-controller store-controller)) (remove-kv key (controller-root store-controller))) -(defmethod cache-instance ((sc store-controller) obj) +(defun cache-instance (sc obj) "Cache a persistent object with the controller." + (declare (type store-controller sc)) (setf (get-cache (oid obj) (instance-cache sc)) obj)) -(defmethod get-cached-instance ((sc store-controller) oid class-name) +(defun get-cached-instance (sc oid class-name) "Get a cached instance, or instantiate!" + (declare (type store-controller sc) + (type fixnum oid)) (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance (make-instance class-name :from-oid oid)))) - ;; OID stuff ;; This stuff is all a hack until sequences appear in Sleepycat 4.3 (defvar %oid-entry (uffi:allocate-foreign-object :char 12)) @@ -112,8 +121,9 @@ (defvar %oid-entry-length 12) (defvar %oid-lock-length 16) -(defmethod next-oid ((sc store-controller)) +(defun next-oid (sc) "Get the next OID." + (declare (type store-controller sc)) (sleepycat::next-counter (controller-environment sc) (controller-db sc) *current-transaction* @@ -123,8 +133,6 @@ ;; Open/close (defmethod open-controller ((sc store-controller) &key (recover nil) (recover-fatal nil) (thread t)) - "Opens the underlying environment and all the necessary -database tables." (let ((env (db-env-create))) ;; thread stuff? (setf (controller-environment sc) env) @@ -174,8 +182,6 @@ sc)))) (defmethod close-controller ((sc store-controller)) - "Close the db handles and environment. Tries to wipe out -references to the db handles." (when (slot-value sc 'root) ;; no root (setf (slot-value sc 'root) nil) @@ -226,3 +232,19 @@ (progn , at body) (close-controller *store-controller*)))) +(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 commit-transaction () + "Commit the current transaction." + (db-transaction-commit) + (setq *current-transaction* (vector-pop *transaction-stack*))) + +(defun abort-transaction () + "Abort the current transaction." + (db-transaction-abort) + (setq *current-transaction* (vector-pop *transaction-stack*))) From blee at common-lisp.net Sun Sep 19 17:49:55 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:49:55 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv28034/src Modified Files: elephant.lisp Log Message: updates Date: Sun Sep 19 19:49:55 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.11 elephant/src/elephant.lisp:1.12 --- elephant/src/elephant.lisp:1.11 Thu Sep 16 06:16:14 2004 +++ elephant/src/elephant.lisp Sun Sep 19 19:49:55 2004 @@ -53,6 +53,7 @@ #:store-controller #:open-controller #:close-controller #:with-open-controller #:controller-path #:controller-environment #:controller-db #:controller-root #:add-to-root #:get-from-root + #:start-transaction #:commit-transaction #:abort-transaction #:persistent #:persistent-object #:persistent-metaclass From blee at common-lisp.net Sun Sep 19 17:50:23 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:50:23 +0200 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv28064/src Modified Files: libsleepycat.c Log Message: ICU license stuff Date: Sun Sep 19 19:50:22 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.8 elephant/src/libsleepycat.c:1.9 --- elephant/src/libsleepycat.c:1.8 Thu Sep 16 06:18:27 2004 +++ elephant/src/libsleepycat.c Sun Sep 19 19:50:22 2004 @@ -39,6 +39,20 @@ ;;; 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. +;;; */ /* Pointer arithmetic utility functions */ @@ -369,7 +383,8 @@ if (diff == 0) return sizediff; return diff; } -/* The following is copied from + +/* The following is derived from http://oss.software.ibm.com/cvs/icu/~checkout~/icu/source/common/ustring.c */ typedef uint16_t UChar; From blee at common-lisp.net Sun Sep 19 17:50:38 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:50:38 +0200 Subject: [elephant-cvs] CVS update: elephant/src/metaclasses.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv28091/src Modified Files: metaclasses.lisp Log Message: docstrings fix Date: Sun Sep 19 19:50:38 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.5 elephant/src/metaclasses.lisp:1.6 --- elephant/src/metaclasses.lisp:1.5 Thu Sep 16 06:19:12 2004 +++ elephant/src/metaclasses.lisp Sun Sep 19 19:50:38 2004 @@ -50,7 +50,10 @@ (defclass persistent-metaclass (standard-class) () - (:documentation "Metaclass for persistent classes.")) + (:documentation + "Metaclass for persistent classes. Use this metaclass to +define persistent classes. All slots are persistent by +default; use the :transient flag otherwise.")) (defclass persistent-slot-definition (standard-slot-definition) ()) From blee at common-lisp.net Sun Sep 19 17:51:57 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:51:57 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv28118/src Modified Files: sleepycat.lisp Log Message: better features flags eval-when madness Date: Sun Sep 19 19:51:56 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.10 elephant/src/sleepycat.lisp:1.11 --- elephant/src/sleepycat.lisp:1.10 Thu Sep 16 06:22:41 2004 +++ elephant/src/sleepycat.lisp Sun Sep 19 19:51:56 2004 @@ -134,7 +134,7 @@ #+linux "/usr/local/BerkeleyDB.4.2/lib/libdb.so" ;; this works on FreeBSD - #+(or bsd freebsd) + #+(and (or bsd freebsd) (not darwin)) "/usr/local/lib/db42/libdb.so" #+darwin "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" @@ -570,7 +570,7 @@ ;;; ;;; buffer-stream functions -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :load-toplevel) (defun process-struct-slot-defs (slot-defs struct) (loop for def in slot-defs collect (list (first def) (list (second def) struct))))) From blee at common-lisp.net Sun Sep 19 17:52:19 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:52:19 +0200 Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv28145/src Modified Files: utils.lisp Log Message: transaction stack Date: Sun Sep 19 19:52:18 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.6 elephant/src/utils.lisp:1.7 --- elephant/src/utils.lisp:1.6 Thu Sep 16 06:23:49 2004 +++ elephant/src/utils.lisp Sun Sep 19 19:52:18 2004 @@ -58,6 +58,9 @@ (defvar *auto-commit* T "Commit things not in transactions?") +(defvar *transaction-stack* (make-array 0 :adjustable t :fill-pointer t) + "Used if the user manually creates transactions.") + ;; Stuff the serializer uses (defvar *lisp-obj-id* 0 "Circularity ids for the serializer.") @@ -80,13 +83,15 @@ (make-array 0 :adjustable t :fill-pointer t)) (*store-controller* *store-controller*) (*auto-commit* *auto-commit*) + (*transaction-stack* + (make-array 0 :adjustable t :fill-pointer t)) (*lisp-obj-id* 0) (*circularity-hash* (make-hash-table :test 'eq)) #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0))) (declare (special *current-transaction* sleepycat::*errno-buffer* sleepycat::*buffer-streams* - *store-controller* *auto-commit* + *store-controller* *auto-commit* *transaction-stack* *lisp-obj-id* *circularity-hash* #+(or cmu sbcl allegro) *resourced-byte-spec*)) (funcall thunk))) From blee at common-lisp.net Sun Sep 19 17:52:51 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 19:52:51 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testcollections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv28172/tests Modified Files: testcollections.lisp Log Message: tests for :populate Date: Sun Sep 19 19:52:51 2004 Author: blee Index: elephant/tests/testcollections.lisp diff -u elephant/tests/testcollections.lisp:1.1 elephant/tests/testcollections.lisp:1.2 --- elephant/tests/testcollections.lisp:1.1 Thu Sep 16 06:26:37 2004 +++ elephant/tests/testcollections.lisp Sun Sep 19 19:52:51 2004 @@ -421,4 +421,31 @@ (pcursor-pkey (cursor-pget-both c 10 101)) (pcursor-pkey (cursor-pget-both-range c 11 111.4)))) - 0 2 10 11 10 9 9999 3000 2000 101 112) \ No newline at end of file + 0 2 10 11 10 9 9999 3000 2000 101 112) + +(defvar index4) + +(deftest newindex + (finishes + (with-transaction () + (setq index4 + (add-index indexed2 :index-name 'crunch :key-form 'crunch + :populate t)))) + t) + +(deftest pcursor2 + (with-btree-cursor (c index4) + (values + (pcursor-pkey (cursor-pfirst c)) + (pcursor-pkey (cursor-pnext c)) + (pcursor-pkey (cursor-pnext-nodup c)) + (pcursor-pkey (cursor-pnext-dup c)) + (pcursor-pkey (cursor-pprev c)) + (pcursor-pkey (cursor-pprev-nodup c)) + (pcursor-pkey (cursor-plast c)) + (pcursor-pkey (cursor-pset c 300)) + (pcursor-pkey (cursor-pset-range c 199.5)) + (pcursor-pkey (cursor-pget-both c 10 101)) + (pcursor-pkey (cursor-pget-both-range c 11 111.4)))) + + 0 2 10 11 10 9 9999 3000 2000 101 112) From blee at common-lisp.net Sun Sep 19 18:04:09 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 19 Sep 2004 20:04:09 +0200 Subject: [elephant-cvs] CVS update: elephant/ChangeLog Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv31463 Modified Files: ChangeLog Log Message: automagic! Date: Sun Sep 19 20:04:09 2004 Author: blee Index: elephant/ChangeLog diff -u elephant/ChangeLog:1.2 elephant/ChangeLog:1.3 --- elephant/ChangeLog:1.2 Thu Sep 2 17:11:58 2004 +++ elephant/ChangeLog Sun Sep 19 20:04:09 2004 @@ -1,4 +1,548 @@ +2004-09-19 12:52 blee + + * tests/testcollections.lisp: tests for :populate + +2004-09-19 12:52 blee + + * src/utils.lisp: transaction stack + +2004-09-19 12:51 blee + + * src/sleepycat.lisp: better features flags eval-when madness + +2004-09-19 12:50 blee + + * src/metaclasses.lisp: docstrings fix + +2004-09-19 12:50 blee + + * src/libsleepycat.c: ICU license stuff + +2004-09-19 12:49 blee + + * src/elephant.lisp: updates + +2004-09-19 12:49 blee + + * src/controller.lisp: docstring fix, some easy transaction + functions + +2004-09-19 12:46 blee + + * src/: berkeley-db.lisp, classes.lisp, collections.lisp: docstring + fix + +2004-09-19 12:44 blee + + * doc/: package-elephant.texinfo, reference.texinfo, + tutorial.texinfo, copying.texinfo, cvs2cl.pl, docstrings.lisp, + elephant.texinfo, intro.texinfo, make-ref.lisp, notes.texinfo: + first version of texinfo docs, automagic changelog + +2004-09-19 12:39 blee + + * NOTES, README, TODO: updates + +2004-09-19 12:38 blee + + * NEWS: updates for release + +2004-09-19 12:37 blee + + * LICENSE: added ICU license bit + +2004-09-19 12:36 blee + + * CREDITS, INSTALL: updates + +2004-09-15 23:29 blee + + * tests/testsorter.lisp: initiali version + +2004-09-15 23:28 blee + + * tests/testsleepycat.lisp: first stab at RT-ifying + +2004-09-15 23:27 blee + + * tests/testserializer.lisp: buffer-streamified + +2004-09-15 23:26 blee + + * tests/testcollections.lisp: test btrees, secondary indices and + cursors + +2004-09-15 23:26 blee + + * tests/mop-tests.lisp: updates makunbound + +2004-09-15 23:25 blee + + * tests/elephant-tests.lisp: updates + +2004-09-15 23:23 blee + + * src/utils.lisp: doc-strings buffer-streams to sleepycat.lisp + with-transaction defaults to *auto-commit* nil + +2004-09-15 23:22 blee + + * src/sleepycat.lisp: split off berkeley-db doc-strings + buffer-streamified cmu pointer arithmetic + +2004-09-15 23:20 blee + + * src/serializer.lisp: doc-strings buffer-streamified sanified type + tags + +2004-09-15 23:19 blee + + * src/berkeley-db.lisp: split from sleepycat.lisp doc-strings + buffer-streamified + +2004-09-15 23:19 blee + + * src/metaclasses.lisp: docstrings changeover to buffer-streams + +2004-09-15 23:18 blee + + * src/libsleepycat.c: need to memcpy on writers (alignment) + lisp-cmp func, assoc / btree cmp stuff cursor pget, remove key + value using cursor length->size + +2004-09-15 23:16 blee + + * src/elephant.lisp: doc-strings slot-makunbound-using-class + +2004-09-15 23:15 blee + + * src/controller.lisp: doc-strings table-layout for btrees better + with-open-store macro + +2004-09-15 23:14 blee + + * src/collections.lisp: doc-strings secondary indices cursors + +2004-09-15 23:14 blee + + * src/classes.lisp: doc-strings slot-makunbound-using-class init + transients after persistents + +2004-09-15 23:12 blee + + * elephant.asd: berkeley-db license description + +2004-09-15 23:11 blee + + * elephant-tests.asd: testcollections + +2004-09-15 23:11 blee + + * TODO: updates + +2004-09-15 23:11 blee + + * Makefile: libmath, bumped version + +2004-09-04 04:16 blee + + * tests/: elephant-tests.lisp, mop-tests.lisp, testserializer.lisp: + fixed imports + +2004-09-04 04:03 blee + + * Makefile: back to Linux default + +2004-09-04 03:59 blee + + * src/serializer.lisp: really fixed the array types (hopefully!) + +2004-09-04 03:28 blee + + * src/controller.lisp: incorporated Rafal Strzalinski's fix (don't + close environments / db's twice) + +2004-09-04 03:24 blee + + * tests/elephant-tests.lisp: initial version + +2004-09-04 03:24 blee + + * tests/: mop-tests.lisp, testserializer.lisp: made into RT tests, + added a bunch + +2004-09-04 03:23 blee + + * src/utils.lisp: fixed macro arg (dynamic, not lexical) / typo + fixed finalizer in allegro (don't close over the value or it will + never be collected) + +2004-09-04 03:20 blee + + * src/serializer.lisp: +base-char+ => +char+ handle uninterned + symbols / symbols in another package optimizations / fixes for + bignums fill-pointers circularity fixes (big typo!) automatic + numeric array definition types + +2004-09-04 03:17 blee + + * src/elephant.lisp: update + +2004-09-04 03:16 blee + + * src/controller.lisp: fixed macros + +2004-09-04 03:16 blee + + * src/classes.lisp: initialize-instance obj : forgot to cache + instances initialize-instance class => shared-initialize : + reinitialize instance fixes shared-initialize obj : transients + before persistents + +2004-09-04 03:13 blee + + * elephant.asd: typo + +2004-09-04 03:12 blee + + * elephant-tests.asd: initial version + +2004-09-04 03:12 blee + + * TODO: update + +2004-09-02 10:19 blee + + * INSTALL: update of docs (for openmcl, revisions) + +2004-09-02 10:11 blee + + * ChangeLog, INSTALL, NEWS, TODO, TUTORIAL: update of docs (for + openmcl, revisions) + +2004-09-02 09:47 blee + + * src/elephant.lisp: turns out i need to shadow with-transaction + after all! + +2004-09-02 09:47 blee + + * src/utils.lisp: nested transactions are borking -- kword default + to with-transactions should be '*current-transaction*, not + *current-transaction* -- i want to capture the dynamic, not + lexical environment + +2004-09-02 09:47 blee + + * src/sleepycat.lisp: next-oid fix: bug in counters, they weren't + using the parent transactions and so were dead locking inside of + with-transactions + + nested transactions are borking -- kword default to + with-transactions should be '*current-transaction*, not + *current-transaction* -- i want to capture the dynamic, not + lexical environment + +2004-09-02 09:45 blee + + * src/libsleepycat.c: next-oid fix: bug in counters, they weren't + using the parent transactions and so were dead locking inside of + with-transactions + +2004-09-02 09:42 blee + + * src/controller.lisp: next-oid fix: bug in counters, they weren't + using the parent transactions and so were dead locking inside of + with-transactions + +2004-09-02 09:41 blee + + * src/classes.lisp: typo + +2004-09-02 09:39 blee + + * TUTORIAL: comments on initforms and transactions + +2004-09-02 02:32 blee + + * tests/testserializer.lisp: typo + +2004-09-02 02:30 blee + + * tests/mop-tests.lisp: initarg / form tests + +2004-09-02 02:21 blee + + * src/utils.lisp: reorder, typos + +2004-09-02 02:18 blee + + * src/sleepycat.lisp: openmcl, errors on library load failure + +2004-09-02 02:15 blee + + * src/metaclasses.lisp: openmcl + +2004-09-02 02:10 blee + + * src/elephant.lisp: openmcl + +2004-09-02 02:09 blee + + * src/classes.lisp: openmcl, fixed shared-initialize, + slot-mkunbound + +2004-09-02 02:05 blee + + * TODO: notes from rtoy on bignums + +2004-09-02 02:03 blee + + * Makefile: conditionalize darwin + +2004-09-02 02:01 blee + + * INSTALL: 0.1 + +2004-08-30 18:53 blee + + * NEWS: versions + +2004-08-30 18:46 blee + + * CREDITS, INSTALL, NEWS, README: edits + +2004-08-30 17:05 blee + + * README: reorg + +2004-08-30 17:05 blee + + * CREDITS, ChangeLog, NEWS: initial version + +2004-08-30 16:39 blee + + * tests/mop-tests.lisp, tests/testserializer.lisp, + tests/testsleepycat.lisp, TODO: initial version + +2004-08-30 16:37 blee + + * NOTES: added preliminary notes on the metaclass stuff + +2004-08-30 16:36 blee + + * src/sleepycat.lisp: db-delete-* returns T on success, Nil if it + couldn't find the record + +2004-08-30 16:14 blee + + * src/elephant.lisp: merged in andrew's fixes: class slots, + inheritence. + +2004-08-30 16:14 blee + + * src/: classes.lisp, metaclasses.lisp: merged in andrew's fixes: + class slots, inheritence. added slot-boundp, slot-makunbound. + +2004-08-29 15:41 blee + + * src/sleepycat.lisp: new license, non-interned exports (thanks + Rafal Strzalinski) + +2004-08-29 15:40 blee + + * src/serializer.lisp: new license, bignum bugfix, don't save class + slots + +2004-08-29 15:40 blee + + * src/metaclasses.lisp: new license, declare optimize + +2004-08-29 15:39 blee + + * src/: libsleepycat.c, utils.lisp: new license + +2004-08-29 15:38 blee + + * src/elephant.lisp: new license, non-interned exports + +2004-08-29 15:37 blee + + * src/controller.lisp: new license, better defaults for root + methods + +2004-08-29 15:36 blee + + * src/collections.lisp: new license, should return values on setf + +2004-08-29 15:35 blee + + * elephant.asd, src/classes.lisp: new license + +2004-08-29 15:35 blee + + * TUTORIAL: updates, persistent classes, collections, threading, + performance + +2004-08-29 15:34 blee + + * Makefile: first version, thank you Rafal Strzalinski + +2004-08-29 15:32 blee + + * LICENSE: new license + +2004-08-29 15:31 blee + + * INSTALL: updates + +2004-08-29 02:55 blee + + * src/sleepycat.lisp: linux / sbcl, reorg + +2004-08-29 02:54 blee + + * src/serializer.lisp: split off utils.lisp, cleanup + +2004-08-29 02:54 blee + + * src/libsleepycat.c: next_counter: release lock on error, + DB_TXN_NOSYNC (speed!) + +2004-08-29 02:53 blee + + * src/elephant.lisp: updates, split off utils.lisp, sbcl imports + for MOP + +2004-08-29 02:51 blee + + * TUTORIAL, INSTALL: open/close-store + +2004-08-29 02:48 blee + + * src/controller.lisp: missing generic warnings, open/close-store + +2004-08-29 02:48 blee + + * src/collections.lisp: missing generic warnings + +2004-08-29 02:47 blee + + * src/utils.lisp: initial version + +2004-08-29 02:46 blee + + * src/: classes.lisp, metaclasses.lisp: andrew's new stuff, work + for sbcl + +2004-08-29 02:45 blee + + * elephant.asd: license, new metaclass / util files + +2004-08-29 02:45 blee + + * TUTORIAL: typos + +2004-08-29 02:44 blee + + * NOTES: updates + +2004-08-29 02:43 blee + + * INSTALL: linux / sbcl + +2004-08-28 01:41 blee + + * src/sleepycat.lisp: fixed with-transaction (no separate retry + version) to use throw / catch (non-consing!). + + poor man's counters. + +2004-08-28 01:41 blee + + * src/serializer.lisp: deserialize can take nil + +2004-08-28 01:40 blee + + * src/libsleepycat.c: poor man's counters + +2004-08-28 01:40 blee + + * src/elephant.lisp: no with-transaction-retry + +2004-08-28 01:39 blee + + * src/controller.lisp: poor man's counters, performance tweaking + +2004-08-28 01:39 blee + + * src/collections.lisp: performance tweaking + +2004-08-28 01:37 blee + + * elephant.asd: changed to serial compilation -- still getting + weird performance issues with recompilation! + +2004-08-27 12:32 blee + + * src/: libsleepycat.c, serializer.lisp, sleepycat.lisp: license + +2004-08-27 12:31 blee + + * src/: controller.lisp, elephant.lisp: license, name changes, + with-transaction* defaulters + +2004-08-27 12:31 blee + + * src/: classes.lisp, collections.lisp: license, name changes + +2004-08-27 12:31 blee + + * NOTES: more changes than i can count + +2004-08-27 12:28 blee + + * INSTALL, functions.lisp, elephant.asd, TUTORIAL, README, LICENSE: + first version + +2004-08-26 21:59 blee + + * NOTES: beginning of a developer doc + +2004-08-26 21:58 blee + + * src/collections.lisp: integrated with new serializer + +2004-08-26 21:58 blee + + * src/controller.lisp: the great simplification effort - specials + +2004-08-26 21:57 blee + + * src/elephant.lisp: weak hashes + +2004-08-26 21:57 blee + + * src/serializer.lisp: aggregate object support + +2004-08-26 21:54 blee + + * src/: sleepycat.lisp, libsleepycat.c: beginning of lock and + cursor support + +2004-08-26 21:53 blee + + * src/classes.lisp: new MOP stuff + +2004-08-19 12:05 blee + + * src/: classes.lisp, collections.lisp, controller.lisp, + elephant.lisp, serializer.lisp, sleepycat.lisp, libsleepycat.c: + Initial revision + +2004-08-19 12:05 blee + + * src/: classes.lisp, collections.lisp, controller.lisp, + elephant.lisp, serializer.lisp, sleepycat.lisp, libsleepycat.c: + Start -9/02/2004 - Alpha 0.1-p1: OID counter bugfix, OpenMCL support. - -8/30/2004 - Alpha 0.1. \ No newline at end of file From blee at common-lisp.net Tue Sep 21 01:34:34 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 03:34:34 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv5811/src Modified Files: collections.lisp Log Message: typo: forgot populate keyword on generic add-index Date: Tue Sep 21 03:34:32 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.8 elephant/src/collections.lisp:1.9 --- elephant/src/collections.lisp:1.8 Sun Sep 19 19:48:11 2004 +++ elephant/src/collections.lisp Tue Sep 21 03:34:31 2004 @@ -106,7 +106,7 @@ (declare (ignore slot-names rest)) (setf (indices-cache instance) (indices instance))) -(defgeneric add-index (bt &key index-name key-form) +(defgeneric add-index (bt &key index-name key-form populate) (:documentation "Add a secondary index. The indices are stored in an eq hash-table, so the index-name should be a symbol. key-form From blee at common-lisp.net Tue Sep 21 01:35:12 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 03:35:12 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv5844/src Modified Files: elephant.lisp Log Message: typo: forgot remove-from-root Date: Tue Sep 21 03:35:11 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.12 elephant/src/elephant.lisp:1.13 --- elephant/src/elephant.lisp:1.12 Sun Sep 19 19:49:55 2004 +++ elephant/src/elephant.lisp Tue Sep 21 03:35:11 2004 @@ -52,7 +52,8 @@ #: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 + #:controller-db #:controller-root + #:add-to-root #:get-from-root #:remove-from-root #:start-transaction #:commit-transaction #:abort-transaction #:persistent #:persistent-object #:persistent-metaclass From blee at common-lisp.net Tue Sep 21 01:37:21 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 03:37:21 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv8199/src Modified Files: sleepycat.lisp Log Message: use asdf packaging info Date: Tue Sep 21 03:37:21 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.11 elephant/src/sleepycat.lisp:1.12 --- elephant/src/sleepycat.lisp:1.11 Sun Sep 19 19:51:56 2004 +++ elephant/src/sleepycat.lisp Tue Sep 21 03:37:21 2004 @@ -144,7 +144,11 @@ ;; Libsleepycat.so: edit this (unless (uffi:load-foreign-library - "/usr/local/share/common-lisp/elephant-0.2/libsleepycat.so" + (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!")) From blee at common-lisp.net Tue Sep 21 01:38:14 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 03:38:14 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv8794/tests Modified Files: elephant-tests.lisp Log Message: use asdf packaging info Date: Tue Sep 21 03:38:12 2004 Author: blee Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.3 elephant/tests/elephant-tests.lisp:1.4 --- elephant/tests/elephant-tests.lisp:1.3 Thu Sep 16 06:25:19 2004 +++ elephant/tests/elephant-tests.lisp Tue Sep 21 03:38:12 2004 @@ -82,7 +82,12 @@ (in-package :ele-tests) -(defvar *testdb-path* "/usr/local/share/common-lisp/elephant-0.2/tests/testdb") +(defvar *testdb-path* + ;;"/usr/local/share/common-lisp/elephant-0.2/tests/testdb" + (namestring + (merge-pathnames + #p"tests/testdb/" + (asdf:component-pathname (asdf:find-system 'elephant-tests))))) (defun do-all-tests() (with-open-store (*testdb-path*) From blee at common-lisp.net Tue Sep 21 01:38:57 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 03:38:57 +0200 Subject: [elephant-cvs] CVS update: elephant/Makefile Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv10579 Modified Files: Makefile Log Message: no install anymore, should be local to asdf Date: Tue Sep 21 03:38:56 2004 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.4 elephant/Makefile:1.5 --- elephant/Makefile:1.4 Thu Sep 16 06:11:00 2004 +++ elephant/Makefile Tue Sep 21 03:38:56 2004 @@ -15,8 +15,6 @@ #DBLIBDIR=/usr/local/lib/db42 #DBINCDIR=/usr/local/include/db42 -INSTALLDIR=/usr/local/share/common-lisp/elephant-0.2/ - ifeq (Darwin,$(UNAME)) SHARED=-bundle else @@ -26,5 +24,3 @@ libsleepycat.so: src/libsleepycat.c gcc $(SHARED) -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm -install: libsleepycat.so - install $< $(INSTALLDIR) From blee at common-lisp.net Tue Sep 21 19:34:37 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 21:34:37 +0200 Subject: [elephant-cvs] CVS update: elephant/TODO Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv2207 Modified Files: TODO Log Message: update Date: Tue Sep 21 21:34:37 2004 Author: blee Index: elephant/TODO diff -u elephant/TODO:1.6 elephant/TODO:1.7 --- elephant/TODO:1.6 Sun Sep 19 19:41:43 2004 +++ elephant/TODO Tue Sep 21 21:34:37 2004 @@ -43,4 +43,7 @@ cursor-put : move the cursor after insert. -change :transient flag to an allocation type (fix CMUCL!) \ No newline at end of file +change :transient flag to an allocation type (fix CMUCL!) + +make update-class-for-redefined-class work. (persistent +slots are class allocated, this is bad.) From blee at common-lisp.net Tue Sep 21 19:35:30 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 21:35:30 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv2234/src Modified Files: classes.lisp Log Message: added preliminary support for change-class (though redef class is broken.) Date: Tue Sep 21 21:35:29 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.11 elephant/src/classes.lisp:1.12 --- elephant/src/classes.lisp:1.11 Sun Sep 19 19:47:44 2004 +++ elephant/src/classes.lisp Tue Sep 21 21:35:29 2004 @@ -111,6 +111,20 @@ ;; let the implementation initialize the transient slots (apply #'call-next-method instance transient-slot-inits initargs))))) +(defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) + "Need to also update the persistent-slots, which have +:class allocation." + (let ((new-persistent-slots + (loop for slotd in (class-slots (class-of current)) + for slot-name = (slot-definition-name slotd) + with old-slot-names = (mapcar #'slot-definition-name + (class-slots (class-of previous))) + when (and (not (member slot-name old-slot-names :test #'eq)) + (persistent-p slotd)) + collect slot-name))) + (apply #'shared-initialize current new-persistent-slots initargs) + (call-next-method))) + (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." (declare (optimize (speed 3)) From blee at common-lisp.net Tue Sep 21 19:36:05 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 21:36:05 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv2520/src Modified Files: collections.lisp Log Message: make shared-init on indexed-btree play nice Date: Tue Sep 21 21:36:04 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.9 elephant/src/collections.lisp:1.10 --- elephant/src/collections.lisp:1.9 Tue Sep 21 03:34:31 2004 +++ elephant/src/collections.lisp Tue Sep 21 21:36:03 2004 @@ -103,8 +103,9 @@ (defmethod shared-initialize :after ((instance indexed-btree) slot-names &rest rest) - (declare (ignore slot-names rest)) - (setf (indices-cache instance) (indices instance))) + (declare (ignore rest)) + (if (member 'indices slot-names :test #'eq) + (setf (indices-cache instance) (indices instance)))) (defgeneric add-index (bt &key index-name key-form populate) (:documentation From blee at common-lisp.net Tue Sep 21 19:36:36 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 21 Sep 2004 21:36:36 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/mop-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv4131/tests Modified Files: mop-tests.lisp Log Message: new tests for change class, update class Date: Tue Sep 21 21:36:35 2004 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.5 elephant/tests/mop-tests.lisp:1.6 --- elephant/tests/mop-tests.lisp:1.5 Thu Sep 16 06:26:08 2004 +++ elephant/tests/mop-tests.lisp Tue Sep 21 21:36:34 2004 @@ -177,4 +177,45 @@ (find-slot-def 'p-class 'slot1)) ) (signals-condition (slot1 p))) + t) + +(deftest update-class + (progn + (defclass update-class () + ((slot1 :initform 1 :accessor slot1)) + (:metaclass persistent-metaclass)) + (let* ((*auto-commit* t) + (foo (make-instance 'update-class))) + (defclass update-class () + ((slot2 :initform 2 :accessor slot2)) + (:metaclass persistent-metaclass)) + (values + (slot2 foo) + (signals-condition (slot1 foo))))) + 2 t) + +(deftest change-class + (progn + (defclass class-one () + ((slot1 :initform 1 :accessor slot1)) + (:metaclass persistent-metaclass)) + + (defclass class-two () + ((slot1 :initform 0 :accessor slot1) + (slot2 :initform 2 :accessor slot2)) + (:metaclass persistent-metaclass)) + + (let* ((*auto-commit* t) + (foo (make-instance 'class-one))) + (change-class foo (find-class 'class-two)) + (values + (slot1 foo) + (slot2 foo)))) + 1 2) + +(deftest change-class2 + (with-transaction () + (let ((foo (make-instance 'btree))) + (change-class foo (find-class 'indexed-btree)) + (is-not-null (indices foo)))) t) From blee at common-lisp.net Sat Sep 25 18:57:37 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 25 Sep 2004 20:57:37 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv19911/src Modified Files: collections.lisp Log Message: because of allocation type weirdness, should always init indices-cache Date: Sat Sep 25 20:57:37 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.10 elephant/src/collections.lisp:1.11 --- elephant/src/collections.lisp:1.10 Tue Sep 21 21:36:03 2004 +++ elephant/src/collections.lisp Sat Sep 25 20:57:37 2004 @@ -103,9 +103,8 @@ (defmethod shared-initialize :after ((instance indexed-btree) slot-names &rest rest) - (declare (ignore rest)) - (if (member 'indices slot-names :test #'eq) - (setf (indices-cache instance) (indices instance)))) + (declare (ignore slot-names rest)) + (setf (indices-cache instance) (indices instance))) (defgeneric add-index (bt &key index-name key-form populate) (:documentation