Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv9614/src

Modified Files: classes.lisp collections.lisp controller.lisp elephant.lisp metaclasses.lisp sleepycat.lisp sql-collections.lisp Added Files: IAN-TODO index-tutorial.lisp index-utils.lisp indexing.lisp Log Message: Merger from Ian's branch into the main trunk.

--- /project/elephant/cvsroot/elephant/src/IAN-TODO 2006/01/26 04:03:44 1.1 +++ /project/elephant/cvsroot/elephant/src/IAN-TODO 2006/02/07 23:23:50 1.2 @@ -0,0 +1,102 @@ +TODO: +- Finish adding tests! +- Documentation (Robert) +- Tutorial example (Ian) + +CLEANUP: +- Verify locking behavior in transactions (should timeout with error!) +- validate native string serialization for allegro in sleepycat.lisp (6.2 trial?) + +FUTURE: +- Add compiled query language (0.5.2) +- Changing slots should push default value into new persistent slots (ie name change) + for existing slots in DB when :class is the synch type +- performance validation of allegro native string serialization (0.5.2) +- Fix multi-repository handling (Ian/Richard) (0.5.2) +- Closer to MOP conversion? (Check licensing) (0.5.3) +- Time/Space performance tuning on indexed slots (0.5.4) + - Reclaim storage on secondary index drop? + - Compute dependencies on derived slots to improve performance + - Optimize consistency updating of inverted indices (currently remove/add) + - Custom DB table instead of using primary/secondary? + - Do not store duplicates in inverted index, store a list of + objects instead that can be operated on cheaply? +- Help Robert integrate his in-memory alternative (non-concurrent mode) + (change use of bdb settings & class slot read/write behavior) (0.6.0) + +DOCUMENTATION: + +Defining Indexed Persistent Classes + +Elephant now contains the facility for default class instance indexing and inverted +indicies defined against slots or functions that compute derived parameters. + +Class indexing is enabled whenever an inverted index is specified. Later releases +may allow for class indexing without inverted indices. Indexing can be specified +interactively at runtime or by :indexed t/nil slot initargs in the class definition. +Only persistent slots can be indexed and derived index functions may only depend on +persistent slots (although no error checking is currently performed on derived slots) + +When a slot is declared indexed, each write to an indexed persistent slot results in +an update to a dedicated class indexed-btree. This btree is organized based on the +instance oid->instance. All class instances can be found by walking the primary +indexed btree. Inverted indices are managed through secondary indices which are +automatically updated by writes to the primary index. Each slot index and derived +index has a secondary (btree-index) btree dedicate to it. This functionality is +similar to that defined for the Symbolics Statice database. + +Writes to classes with an inverted index on the written slot are more expensive than +standard writes. They involves, at least, three additional reads to verify that the +primary index key-value and secondary index key-value are the same. To validate +the secondary key-value pair the persistent value is read again by the key-function +defined on the secondary index. This is very appropriate for read heavy, interactive +systems that will be using the indexes alot, but less so for write-dominated archives +such as log files. Log files that are infrequently read are better off stored without +indexing using a linked list with a market index that taps into the linked list at +various points according to date, sequence number, etc. Systems that care little about +throughput can be agnostic to the performance impact as read/writes are likely to be +a very small part of the total runtime. (Can I justify this statement empirically?) + +Interactive manipulation of indexing is allowed through an API defined in indexing.lisp. +Classes can have indexing enabled/disabled. Individual slots can be registered and +unregistered as indexed slots and derived slots can be added only via the interactive +functions. + +There are some touchy issues in reconnecting to an existing indexed slot database. +Elephant does not yet support persistent classes and so interactive changes to indexing +may clash with the initargs in the original defclass. If this is the case, the system +will adapt the defined class to the persistent state and warn the user that the text +is out of date with the persistent indexing state. It is a good idea to change slot +indexing behavior using change-class or by re-evaluating a changed class definition. +In the lisp tradition, we'll assume you know what you're doing when you interactively +change things so we'll maintain derived indices. If they have slot dependencies that +are lost under a change-class operation then there will be an error issued by the +derived function at runtime and you'll have to drop and restart that index. We may +add some more sophistication here at a later date (such as allowing specification of +the slots a derived index depends on so we can automatically drop and compute updates. + +Database Queries for Indexed Instances + +All the above functionality leaves us with a set of indexed instances. The indexing +functionality provides three APIs for leveraging this infrastructure in your programs. + +1) Simplified cursor interface. You can use the underlying btree cursors directly if +you want to do sophisticated operations over the indices. Be sure to wrap side effects +to the store in with-transaction statements and to close your indices when done. + +2) Instance set retrieval. You can retrieve sets of instances using simple interfaces +that retrieve instances by slot value, a range of slot values (range is determined +using the built-in elephant key order routine) or all class instances. This API also +allows mapping over ranges, sets of values or all class instances. + +3) Query language. This is relatively primitive for now, it allows you to do joins +over multiple slot or derived indices to pick a subset of classes that satisfy a given +relation. Later we hope to allow for more complex class instance inter-dependencies, +for example persistent graphs where subgraphs are deferentiated by class-type or slot +values. + +See the API reference for + + + + --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/05 23:13:07 1.18 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/07 23:23:50 1.19 @@ -54,6 +54,31 @@ metaclass.") (:metaclass persistent-metaclass))

+;;(defmethod print-object ((obj persistent) stream) + +(defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys) + (declare (ignore initargs)) + (if (indexed (class-of instance)) + (progn + (let ((oid (oid instance))) + (declare (type fixnum oid)) + (inhibit-indexing oid) + (unwind-protect + (call-next-method) + (uninhibit-indexing oid)) + ;; Inhibit indexing if the object already was defined (ie being created from an oid) + ;; as it should be indexed already. This hack avoids a deadlock situation where we + ;; write the class or index page that we are currently reading via a cursor without + ;; going through the cursor abstraction. There has to be a better way to do this. + (when (not from-oid) + (let ((class-index (find-class-index (class-of instance)))) + (when class-index +;; (format t "Indexing initial instance: ~A :: ~A~%" oid instance) + (with-transaction () + (setf (get-value oid class-index) instance))))))) + ;; else + (call-next-method))) + (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)) @@ -89,10 +114,13 @@

#+allegro (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) (loop with persistent-slots = (persistent-slots instance) for slot-def in (class-direct-slots instance) when (member (slot-definition-name slot-def) persistent-slots) @@ -101,19 +129,24 @@

#+(or cmu sbcl openmcl) (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) (make-instances-obsolete instance))))

;; #+allegro (defmethod finalize-inheritance :around ((instance persistent-metaclass)) (prog1 (call-next-method) - (if (not (slot-boundp instance '%persistent-slots)) + (when (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) - (cons (persistent-slot-names instance) nil))))) + (cons (persistent-slot-names instance) nil))) + (when (not (slot-boundp instance '%indexed-slots)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)))))

;; #+(or cmu sbcl) ;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) @@ -169,17 +202,16 @@ (apply #'call-next-method instance transient-slot-inits initargs))))))

(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) - ;; probably should delete discarded slots, but we'll worry about that later + ;; NOTE: probably should delete discarded slots, but we'll worry about that later + (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) -;; (format t "persistent-slots ~A~%" (persistent-slots (class-of instance))) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) (old-persistent-slots class)))) - + ;; Update new persistent slots, the others we get for free (same oid!) + ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) ) )

@@ -200,7 +232,9 @@ when (not (persistent-slot-boundp previous slot-name)) collect slot-name)) (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) + ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) + ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) do (setf (slot-value-using-class new-class @@ -209,6 +243,9 @@ (slot-value-using-class old-class previous (find-slot-def-by-name old-class (slot-definition-name slot-def))))) + ;; Delete this instance from its old class index, if exists + (when (indexed old-class) + (remove-kv (oid previous) (find-class-index old-class))) (call-next-method)))

(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) @@ -217,11 +254,21 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name)))

+;; ORIGINAL METHOD +;; (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +;; "Set the slot value in the database." +;; (declare (optimize (speed 3))) +;; (let ((name (slot-definition-name slot-def))) +;; (persistent-slot-writer new-value instance name))) + +;; SUPPORT FOR INVERTED INDEXES (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) - (let ((name (slot-definition-name slot-def))) - (persistent-slot-writer new-value instance name))) + (if (indexed class) + (indexed-slot-writer class instance slot-def new-value) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-writer new-value instance name))))

(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." @@ -242,19 +289,21 @@

(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." - (declare (optimize (speed 3)) - (ignore class)) - (if (sql-store-spec-p (:dbcn-spc-pst instance)) - (progn + (declare (optimize (speed 3))) + ;; NOTE: call remove-indexed-slot here instead? + (when (indexed slot-def) + (unregister-indexed-slot class (slot-definition-name slot-def))) + (if (sql-store-spec-p (:dbcn-spc-pst instance)) + (progn (let* ((sc (check-con (:dbcn-spc-pst instance))) (con (controller-db sc))) - (sql-remove-from-root - (form-slot-key (oid instance) (slot-definition-name slot-def)) - sc - con - ) - )) - (with-buffer-streams (key-buf) + (sql-remove-from-root + (form-slot-key (oid instance) (slot-definition-name slot-def)) + sc + con + ) + )) + (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize (slot-definition-name slot-def) key-buf) (db-delete-buffered --- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/02/04 22:25:09 1.14 +++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/02/07 23:23:50 1.15 @@ -121,11 +121,9 @@

(defclass bdb-indexed-btree (indexed-btree bdb-btree ) ( - (indices :accessor indices :initform (make-hash-table) - ) + (indices :accessor indices :initform (make-hash-table)) (indices-cache :accessor indices-cache :initform (make-hash-table) - :transient t -) + :transient t) ) (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) @@ -276,6 +274,7 @@ (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? + ;; Manually write value into secondary index (buffer-write-int (oid index) secondary-buf) (serialize secondary-key secondary-buf) ;; should silently do nothing if the key/value already @@ -355,7 +354,7 @@ "Puts are not allowed on secondary indices. Try adding to the primary." (declare (ignore value key) - (ignorable bt)) + (ignorable bt)) (error "Puts are forbidden on secondary indices. Try adding to the primary."))

(defgeneric get-primary-key (key bt) --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/05 23:13:07 1.16 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/07 23:23:50 1.17 @@ -32,15 +32,17 @@ )

(defun get-controller (spec) - (let ((store-controllers nil)) - (dolist (s *strategies*) - (let ((sc (funcall s spec))) - (if sc - (push sc store-controllers)))) - (if (not (= (length store-controllers) 1)) - (error "Strategy resolution for this spec completely failed!") - (car store-controllers)) - )) + (let ((cached-sc (gethash spec *dbconnection-spec*))) + (if cached-sc cached-sc + (let ((store-controllers nil)) + (dolist (s *strategies*) + (let ((sc (funcall s spec))) + (if sc + (push sc store-controllers)))) + (if (not (= (length store-controllers) 1)) + (error "Strategy resolution for this spec completely failed!") + (car store-controllers)) + ))))

(defclass store-controller () @@ -50,6 +52,7 @@ :accessor controller-path :initarg :path) (root :reader controller-root) + (class-root :reader controller-class-root) (db :type (or null pointer-void) :accessor controller-db :initform '()) (environment :type (or null pointer-void) :accessor controller-environment) @@ -74,7 +77,7 @@ creation, counters, locks, the root (for garbage collection,) et cetera."))

-;; Without somemore sophistication, these functions +;; Without some more sophistication, these functions ;; need to be defined here, so that they will be available for testing ;; even if you do not use the strategy in question... (defun bdb-store-spec-p (path) @@ -105,6 +108,10 @@ "Close the db handles and environment. Tries to wipe out references to the db handles."))

+(defgeneric reset-instance-cache (sc) + (:documentation + "Creates an empty object cache by replacing the existing cache.")) + (defgeneric build-btree (sc) (:documentation "Construct a btree of the appropriate type corresponding to this store-controller.")) @@ -313,14 +320,23 @@

(let ((root (make-instance 'bdb-btree :from-oid -1 :sc sc))) (setf (slot-value sc 'root) root)) + + (setf (slot-value sc 'class-root) + (make-instance 'bdb-btree :from-oid -2 :sc sc)) + sc)))

+(defmethod reset-instance-cache ((sc store-controller)) + (setf (instance-cache sc) + (make-cache-table :test 'eql))) + (defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) ;; no root + (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) ;; clean instance cache - (setf (instance-cache sc) (make-cache-table :test 'eql)) + (reset-instance-cache sc) ;; close handles / environment (db-sequence-close (controller-oid-seq sc)) (setf (controller-oid-seq sc) nil) @@ -336,7 +352,10 @@ (setf (controller-db sc) nil) (db-env-close (controller-environment sc)) (setf (controller-environment sc) nil) - nil)) + nil) + ;; Delete connection spec so object ops on cached db info fail + (remhash (controller-path *store-controller*) *dbconnection-spec*)) +

;; Do these things need to take &rest arguments? (defmethod build-btree ((sc bdb-store-controller)) @@ -387,15 +406,18 @@ the controller unconditionally on exit." `(unwind-protect (progn - (let (*store-controller* (open-controller ,sc)) + (let ((*store-controller* (open-controller ,sc))) (declare (special *store-controller*)) ,@body)) (close-controller ,sc)))

(defun close-store () "Conveniently close the store controller." + (declare (special *store-controller*)) (if *store-controller* - (close-controller *store-controller*))) + (progn + (close-controller *store-controller*) + (setf *store-controller* nil))))

(defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/04 22:25:09 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/07 23:23:50 1.20 @@ -90,6 +90,24 @@ #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-flags #:db-env-get-flags #:run-elephant-thread + + ;; Class indexing management API + #:*default-indexed-class-synch-policy* + #:find-class-index #:find-inverted-index + #:enable-class-indexing #:disable-class-indexing + #:add-class-slot-index #:remove-class-slot-index + #:add-class-derived-index #:remove-class-derived-index + #:describe-db-class-index + + ;; Low level cursor API + #:make-inverted-cursor #:make-class-cursor + #:with-inverted-cursor #:with-class-cursor + + ;; Instance query API + #:get-instances-by-class + #:get-instances-by-value + #:get-instances-by-range + #:drop-instances ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/03 04:19:44 1.1 +++ /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,94 @@ + +(defpackage elephant-tutorial + (:use :cl :elephant)) + +(in-package :elephant-tutorial) + +(defclass simple-plog () + ((timestamp :accessor plog-timestamp :initarg :timestamp :indexed t) + (type :accessor plog-type :initarg :type :indexed t) + (data :accessor plog-data :initarg :data) + (user :accessor plog-user :initarg :user :indexed t)) + (:metaclass persistent-metaclass) + (:documentation "Simple persistent log")) + +(defclass url-record () + ((url :accessor url-record-url :initarg :url :initform "") + (fetched :accessor url-record-fetched :initarg :fetched :initform nil) + (analyzed :accessor url-record-analyzed :initarg :analyzed :initform nil)) + (:documentation "An application object, declared persistent but not indexed")) + +(defmethod print-object ((obj url-record) stream) + "Pretty print program objects so they're easy to inspect" + (format stream "<url: ~A ~A ~A>" (url-record-url obj) (url-record-fetched obj) (url-record-analyzed obj))) + +(defclass url-log (simple-plog) () + (:metaclass persistent-metaclass) + (:documentation "This class tracks events that transform our program object state")) + +(defmethod print-object ((obj url-log) stream) + "Structured printing of log entries so they're easy to inspect at the repl" + (format stream "#plog[~A :: ~A]" (plog-type obj) (plog-data obj))) + +(defun log-event (user type data) + "A helper function to generically log various events by user" + (make-instance 'url-log + :timestamp (get-universal-time) + :type type + :data data + :user user)) + +(defun report-events-by-time (user start end) + "A custom reporting function for our logs - pull out a time range. A real + implementation might do it by dates or by dates + times using one of the + lisp time libraries" + (let ((entries1 (get-instances-by-range 'url-log 'timestamp start end)) + (entries2 (get-instances-by-value 'url-log 'user user))) + (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2)) + (format t "~{~A~%~}" (nreverse (intersection entries1 entries2))))) + +;; +;; This code is the skeleton of a program +;; + +(defvar *start-timestamp* nil) +(defvar *end-timestamp* nil) + +(defun generate-events (user count &optional delay) + (setf *start-timestamp* (get-universal-time)) + (loop for i from 1 upto count do + (let ((url (get-a-url user i))) + (sleep delay) + (fetch-url url user) + (sleep delay) + (analyze-url url user) + (sleep delay))) + (setf *end-timestamp* (get-universal-time))) + +(defun get-a-url (user seq) + (let ((url (make-instance 'url-record :url (format nil "http://www.common-lisp.net/~A/" seq)))) + (log-event user :received-url url) + url)) + +(defun fetch-url (url user) + (setf (url-record-fetched url) t) + (log-event user :fetched-url url)) + +(defun analyze-url (url user) + (setf (url-record-analyzed url) t) + (log-event user :analyzed-url url)) + +;; Top Level Test Code + +(defun test-generate-and-report (name store-spec) + (open-store store-spec) + (generate-events name 10 0.2) + (report-events name) + (close-store)) + +(defun report-events (name) + (let ((first-third-start *start-timestamp*) + (first-third-end (+ *start-timestamp* + (/ (- *end-timestamp* *start-timestamp*) 3)))) + (report-events-by-time name first-third-start first-third-end))) + --- /project/elephant/cvsroot/elephant/src/index-utils.lisp 2006/01/30 05:09:12 1.1 +++ /project/elephant/cvsroot/elephant/src/index-utils.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,128 @@ + + +(in-package :elephant) + +;; +;; Simple utilities for managing synchronization between class +;; definitions and database state +;; + +(defmethod class-index-cached? ((class persistent-metaclass)) + (and (slot-boundp class '%index-cache) + (subtypep (type-of (%index-cache class)) 'btree))) + +(defmethod determine-synch-method ((class persistent-metaclass)) + "This method should be called on the class if the %index-cache slot is + not a subtype of class btree to determine what synch method to call + on the current database btree. If DB doesn't exist, then you can ignore this" + (cond ((not (slot-boundp class '%index-cache)) + *default-indexed-class-synch-policy*) + ((member (%index-cache class) '(:class :union :db)) + (%index-cache class)) + (t *default-indexed-class-synch-policy*))) + +(defmethod set-db-synch ((class persistent-metaclass) method) + "Tell the class the synch method to use to synchronize the class indices + and the current class definition" + (assert (member method '(:class :db :union))) + (setf (%index-cache class) method)) + +;; +;; Differentiate derived indices from slot-based ones +;; + +(defparameter *derived-index-marker* "%%derived%%-") + +(defun make-derived-name (name) + (intern (format nil "~A~A" *derived-index-marker* name))) + +(defun derived-name? (name) + (when (symbolp name) (setf name (symbol-name name))) + (string= (subseq name 0 (min (length name) + (length *derived-index-marker*))) + *derived-index-marker*)) + +(defun get-derived-name-root (dname) + (when (symbolp dname) (symbol-name dname)) + (intern (subseq dname (length *derived-index-marker*)))) + +;; +;; Interface fn for slot key forms +;; + +(defun make-slot-key-form (class name) + (assert (member name (car (%persistent-slots class)))) + `(lambda (slot-index primary instance) + (declare (ignore slot-index primary)) + (read-slot-for-index ',(class-name class) ',name instance))) + +(defun read-slot-for-index (class-name slot-name instance) + (let ((class (find-class class-name))) + (multiple-value-bind (found? slot-def) (find-effective-slot-def class slot-name) + (when (and found? + (slot-boundp-using-class class instance slot-def)) + (values t (persistent-slot-reader instance slot-name)))))) + +(defun find-effective-slot-def (class slot-name) + (loop for slot in (class-slots class) do + (when (eq (slot-definition-name slot) slot-name) + (return (values t slot))))) + + +;; +;; Simplify the computations for derived parameters +;; + +(defun make-derived-key-form (dform) + "Change the index function interface for derived class slotsw + to better handle the various use cases. The provided function + accepts a single argument, the class instance to comput a + dervied parameter against. Dervied indices can + specify that the result should not be indexed by returning + two values (values nil t) the second of which is an ignore + specifier. Normal functions just return the value which is + an implicit index command. Accessors that compute against + unbound slots are silently ignored (ie initialization) and + errors of other types produce warnings and are ignored. This + handles both named functions and anonymous lambdas." + `(lambda (slot-index primary instance) + (declare (ignore slot-index primary)) + (compute-derived-key-result instance #',dform))) + +(defun compute-derived-key-result (instance fn) + (handler-case + (multiple-value-bind (val ignore) + (funcall fn instance) + (if ignore + (values nil nil) + (values t val))) + (unbound-slot () + (values nil nil)) + (error (e) + (warn "Error ~A computing derived index for on instance ~A" e instance) + (values nil nil)))) + +;; +;; This has turned out to be useful for debugging +;; + + +(defun describe-db-class-index (class-name &key (sc *store-controller*)) + (let ((class-idx (find-class-index class-name :sc sc))) + (if class-idx + (let ((names nil)) + (maphash (lambda (k v) + (declare (ignore v)) + (push k names)) + (indices-cache class-idx)) + (format t "Class Index: ~A~%" class-name) + (format t "~{~A~%~}" (nreverse names))) + (format t "No persistent index for class ~A.~%" class-name)))) + +(defun wipe-indexed-class (name) + (ignore-errors + (disable-class-indexing name) + (reset-instance-cache *store-controller*) + (setf (find-class name) nil))) + + --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/01/26 04:03:44 1.1 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,548 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; slot-index.lisp -- use btree collections to track objects by slot values +;;; via metaclass options or accessor :after methods +;;; +;;; Initial version 1/24/2006 Ian Eslick +;;; eslick at alum mit edu +;;; +;;; License: Lisp Limited General Public License +;;; http://www.franz.com/preamble.html +;;; + +(in-package "ELEPHANT") + +;; +;; User level class indexing control protocol +;; +;; Operates against the current *store-controller* +;; but many accept a :sc keyword to change the controller +;; The specific indices created can be specialized on the +;; controller type. See the internal implementor protocol +;; below. + +(defparameter *default-indexed-class-synch-policy* :class + "[:union | :db | :class] determines which reference defines + the indexing structure after a reconnect to a persistent + store. If the class is redefined, the default is that the + class dominates. Changing this parameter alters the + default behavior to :union (merge indexed slots from database + and class definition) or :db which changes the indexing of + the class to match the db. This can fail in several ways: + a) the class does not have a persistent slot defined for + a slot index (will be treated as derived & fail on write) + b) A slot has been added with the name of a derived index + this will be confusing + c) The key-slot function definitions (if not an anoymous + lambda) may have changed leading to unexpected indexing") + +(defgeneric find-class-index (persistent-metaclass &rest rest) + (:documentation "This method is the way to access the class index via + the class object. We can always fetch it or we can cache it in + the class itself. It returns an indexed-btree.")) + +(defgeneric find-inverted-index (persistent-metaclass index-name &key null-on-fail) + (:documentation "This method finds an inverted index defined on + the class described by persistent-metaclass.")) + +(defgeneric enable-class-indexing (persistent-metaclass slot-names &rest rest) + (:documentation "Enable a class instance index for this object. It's + an expensive thing to support on writes so know that you need it + before you do it.")) + +(defgeneric disable-class-indexing (persistent-metaclass &rest rest) + (:documentation "Delete and remove class instance indexing and any + secondary indices defined against it")) + +(defgeneric add-class-slot-index (persistent-metaclass slot-name &rest rest) + (:documentation "Add a per-slot class index option to the class + index based on the class accessor method")) + +(defgeneric remove-class-slot-index (persistent-metaclass slot-name &key sc) + (:documentation "Remove the per-slot index from the db")) + +(defgeneric add-class-derived-index (persistent-metaclass name derived-defun &rest rest) + (:documentation "Add a simple secondary index to this class based on + a function that computes a derived parameter. WARNING: derived + parameters are only valid on persistent slots. An arbitrary function + here will fail to provide consistency on transient slots or global + data that is not stored in the persistent store. Derived indexes are + deleted and rebuilt when a class is redefined")) + +(defgeneric remove-class-derived-index (persistent-metaclass name &rest rest) + (:documentation "Remove a derived index by providing the derived name + used to name the derived index")) + + +;; =========================== +;; INDEX UPDATE ROUTINE +;; =========================== + +(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) + "Anything that side effects a persistent-object slot should call this to keep + the dependant indices in synch. Only classes with derived indices need to + update on writes to non-indexed slots." + (let ((slot-name (slot-definition-name slot-def)) + (oid (oid instance))) + (declare (type fixnum oid)) + (if (no-indexing-needed? class instance slot-def oid) + (with-transaction () + (persistent-slot-writer new-value instance slot-name)) + (let ((class-idx (find-class-index class)) + (*auto-commit* nil)) +;; (format t "Indexing object: ~A oid: ~A~%" instance oid) + (with-transaction () + ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement + (when (get-value oid class-idx) + (remove-kv oid class-idx)) + (persistent-slot-writer new-value instance slot-name) + (setf (get-value oid class-idx) instance)))))) + + +(defun no-indexing-needed? (class instance slot-def oid) + (or (and (not (indexed slot-def)) ;; not indexed + (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes + (member oid *inhibit-indexing-list*))) ;; currently inhibited + +;; =========================== +;; CLASS INDEX INTERFACE +;; =========================== + +(defmethod find-class-index ((class-name symbol) &key (sc *store-controller*)) + (find-class-index (find-class class-name) :sc sc)) + +(defmethod find-class-index ((class persistent-metaclass) &key (sc *store-controller*)) + (ensure-finalized class) + (if (class-index-cached? class) + ;; we've got a cached reference, just return it + (%index-cache class) + (multiple-value-bind (btree found) + (get-value (class-name class) (controller-class-root sc)) + (if found + (cache-existing-class-index class btree sc) + (cache-new-class-index class sc))))) + +(defun ensure-finalized (class) + (when (not (class-finalized-p class)) + (warn "Manually finalizing class ~A" (class-name class)) + (finalize-inheritance class))) + +(defun cache-existing-class-index (class btree sc) + "If we have a persistent index already, assign, synchronize & return it" + (let ((method (determine-synch-method class))) + (setf (%index-cache class) btree) + (synchronize-class-to-store class :sc sc :method method) + btree)) + +(define-condition persistent-class-not-indexed (error) + ((class-obj :initarg :class :initarg nil :reader :unindexed-class-obj))) + +(defun cache-new-class-index (class sc) + "If not cached or persistent then this is a new class, make the new index" + (if (indexed class) + (enable-class-indexing class (indexing-record-slots (indexed-record class)) :sc sc) + (signal 'persistent-class-not-indexed + :class class + :format-control "Class ~A is not enabled for indexing" + :format-arguments (list (class-name class))))) + + +(defmethod find-inverted-index ((class symbol) slot &key (null-on-fail nil)) + (find-inverted-index (find-class class) slot :null-on-fail null-on-fail)) + +(defmethod find-inverted-index ((class persistent-metaclass) slot &key (null-on-fail nil)) + (let* ((cidx (find-class-index class)) + (dslot (make-derived-name slot)) + (idx (or (get-index cidx slot) + (get-index cidx dslot)))) + (if idx + idx + (if null-on-fail + nil + (error "Inverted index ~A not found for class ~A with + persistent slots: ~A" slot (class-name class) (car (%persistent-slots class))))))) + +(defmethod find-inverted-index-names ((class persistent-metaclass)) + (let ((names nil)) + (maphash (lambda (name idx) + (declare (ignore idx)) + (push name names)) + (indices (find-class-index class))) + names)) + +;; ============================= +;; INDEXING INTERFACE +;; ============================= + +(defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) + (let ((croot (controller-class-root sc))) + (multiple-value-bind (btree found) + (get-value (class-name class) croot) + (declare (ignore btree)) + (when found (error "Class is already enabled for indexing! Run disable class indexing to clean up."))) + ;; Put class instance index into the class root & cache it in the class object + (with-transaction (:store-controller sc) + (let ((class-idx (build-indexed-btree sc))) + (setf (get-value (class-name class) croot) class-idx) + (setf (%index-cache class) class-idx) + ;; Add all the indexes + (loop for slot in indexed-slot-names do + (add-class-slot-index class slot :populate nil :sc sc)) + ;; Sanity check + (let ((record (indexed-record class))) + (declare (ignorable record)) + (assert (indexed class))) + class-idx)))) + +(defmethod disable-class-indexing ((class-name symbol) &key (errorp t) (sc *store-controller*)) + (let ((class (find-class class-name errorp))) + (when class + (disable-class-indexing class :sc sc)))) + +(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) + (let ((class-idx (find-class-index class :sc sc))) + (unless class-idx (return-from disable-class-indexing nil)) + ;; Remove all instance key/value data from the class index (& secondary indices) + (with-transaction (:store-controller sc) + (with-btree-cursor (cur class-idx) + (when (cursor-first cur) + (loop while (cursor-delete cur))))) + ;; Get the names of all indices & remove them + (let ((names nil)) + (maphash (lambda (name secondary-index) + (declare (ignore secondary-index)) + (push name names)) + (indices-cache class-idx)) + (dolist (name names) + (if (member name (class-slots class)) + (remove-class-slot-index class name) + (with-transaction (:store-controller sc) + (remove-index class-idx name))))) + ;; Drop the class instance index from the class root + (with-transaction (:store-controller sc) + (remove-kv (class-name class) (controller-class-root sc))) + (setf (%index-cache class) nil) + ;; Clear out the current class + (update-indexed-record class nil) + )) + +(defmethod add-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) + (add-class-slot-index (find-class class) slot-name :sc sc)) + +(defmethod add-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (populate t) (update-class t)) + (if (find-inverted-index class slot-name :null-on-fail t) + (warn "Duplicate slot index named ~A requested for class ~A. Ignoring." + slot-name (class-name class)) + (progn + (when update-class (register-indexed-slot class slot-name)) + (with-transaction (:store-controller sc) + (add-index (find-class-index class :sc sc) + :index-name slot-name + :key-form (make-slot-key-form class slot-name) + :populate populate)) + t))) + +(defmethod remove-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) + (remove-class-slot-index (find-class class) slot-name :sc sc)) + +(defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (update-class t)) + ;; NOTE: Write routines to recover BDB storage when you've wiped an index... + ;; NOTE: If the transaction aborts we should not update class slots? + (if (find-inverted-index class slot-name :null-on-fail t) + (progn + (when update-class (unregister-indexed-slot class slot-name)) + (with-transaction (:store-controller sc) + (remove-index (find-class-index class :sc sc) slot-name)) + t) + (progn + (warn "Slot index ~A not found for class ~A" slot-name (class-name class)) + nil))) + +(defmethod add-class-derived-index ((class symbol) name derived-defun &key (sc *store-controller*) (populate t)) + (add-class-derived-index (find-class class) name derived-defun :sc sc :populate populate)) + +(defmethod add-class-derived-index ((class persistent-metaclass) name derived-defun &key (populate t) (sc *store-controller*) (update-class t)) + (let ((class-idx (find-class-index class :sc sc))) + (if (find-inverted-index class (make-derived-name name) :null-on-fail t) + (error "Duplicate derived index requested named ~A on class ~A" name (class-name class)) + (progn + (when update-class (register-derived-index class name)) + (with-transaction (:store-controller sc) + (add-index class-idx + :index-name name + :key-form (make-derived-key-form derived-defun) + :populate populate)))))) + +(defmethod remove-class-derived-index ((class symbol) name &key (sc *store-controller*)) + (remove-class-derived-index (find-class class) name :sc sc)) + +(defmethod remove-class-derived-index ((class persistent-metaclass) name &key (sc *store-controller*) (update-class t)) + (if (find-inverted-index class name :null-on-fail t) + (progn + (when update-class (unregister-derived-index class name)) + (with-transaction (:store-controller sc) + (remove-index (find-class-index class :sc sc) name)) + t) + (progn + (warn "Derived index ~A does not exist in ~A" name (class-name class)) + nil))) + +;; ========================= +;; Low level cursor API +;; ========================= + +(defgeneric make-inverted-cursor (persistent-metaclass name) + (:documentation "Define a cursor on the inverted (slot or derived) index")) + +(defgeneric make-class-cursor (persistent-metaclass) + (:documentation "Define a cursor over all class instances")) + +;; TODO! +;;(defgeneric make-join-cursor ((class persistent-metaclass) &rest specification) +;; (:documentation "Make a join cursor using the slot-value pairs in +;; the specification assoc-list. Support for complex queries +;; requiring new access to db-functions and a new cursor type")) + +;; implementation +(defmethod make-inverted-cursor ((class persistent-metaclass) name) + (make-cursor (find-inverted-index class name))) + +(defmacro with-inverted-cursor ((var class name) &body body) + `(let ((,var (make-inverted-cursor ,class ,name))) + (unwind-protect (progn ,@body) + (cursor-close ,var)))) + +(defmethod make-class-cursor ((class persistent-metaclass)) + (make-cursor (find-class-index class))) + +(defmacro with-class-cursor ((var class) &body body) + `(let ((,var (make-class-cursor ,class))) + (unwind-protect (progn ,@body) + (cursor-close ,var)))) + + +;; ========================= +;; User-level lisp API +;; ========================= + +(defgeneric get-instances-by-class (persistent-metaclass)) +(defgeneric get-instances-by-value (persistent-metaclass slot-name value)) +(defgeneric get-instances-by-range (persistent-metaclass slot-name start end)) + +;; map instances +;; iterate over instances + +(defmethod get-instances-by-class ((class symbol)) + (get-instances-by-class (find-class class))) + +(defmethod get-instances-by-class ((class persistent-metaclass)) + (let ((instances nil) + (cidx (find-class-index class))) + (with-btree-cursor (cur cidx) + (multiple-value-bind (exists? key val) (cursor-first cur) + (declare (ignore key)) + (when exists? + (push val instances) + (loop + (multiple-value-bind (exists? key val) (cursor-next cur) + (declare (ignore key)) + (if exists? + (push val instances) + (return-from get-instances-by-class instances))))))))) + +(defmethod get-instances-by-value ((class symbol) slot-name value) + (get-instances-by-value (find-class class) slot-name value)) + +(defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) + (let ((instances nil)) + (with-btree-cursor (cur (find-inverted-index class slot-name)) + (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) + (declare (ignore skey pkey)) + (when exists? + (push val instances) + (loop + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (declare (ignorable skey pkey)) + (if exists? + (push val instances) + (return-from get-instances-by-value instances))))))))) + +(defmethod get-instances-by-range ((class symbol) slot-name start end) + (get-instances-by-range (find-class class) slot-name start end)) + +(defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) + (with-inverted-cursor (cur class idx-name) + (labels ((next-range (instances) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) + (declare (ignore pkey)) + (if (and exists? (<= skey end)) + (next-in-range skey (cons val instances)) + (nreverse instances)))) + (next-in-range (key instances) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (declare (ignore pkey skey)) + (if exists? + (next-in-range key (cons val instances)) + (progn + (cursor-pset-range cur key) + (next-range instances)))))) + (multiple-value-bind (exists? skey val pkey) (cursor-pset-range cur start) + (declare (ignore pkey)) + (if (and exists? (<= skey end)) + (next-in-range skey (cons val nil)) + nil))))) + +(defun drop-instances (instances &key (sc *store-controller*)) + (assert (consp instances)) + (with-transaction (:store-controller sc)

[151 lines skipped] --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/05 23:13:07 1.12 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/07 23:23:51 1.13 @@ -24,6 +24,7 @@ (make-hash-table :test 'equal))

(defun connection-is-indeed-open (con) + (declare (ignore con)) t ;; I don't yet know how to implement this )

@@ -65,17 +66,23 @@ to user-defined classes and collections.)"))

(defclass persistent-metaclass (standard-class) - ((%persistent-slots :accessor %persistent-slots)) + ((%persistent-slots :accessor %persistent-slots) + (%indexed-slots :accessor %indexed-slots) + (%index-cache :accessor %index-cache)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by -default; use the :transient flag otherwise.")) +default; use the :transient flag otherwise. Slots can also +be indexed for by-value retrieval.")) + +;; +;; Persistent slot maintenance +;;

(defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) - nil) - (car (%persistent-slots class))) + nil))

(defmethod persistent-slots ((class standard-class)) nil) @@ -91,8 +98,9 @@ nil) )))

+ (defclass persistent-slot-definition (standard-slot-definition) - ()) + ((indexed :accessor indexed :initarg :indexed :initform nil :allocation :instance)))

(defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ()) @@ -117,6 +125,115 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil)

+;; +;; Indexed slots maintenance +;; + +;; This just encapsulates record keeping a bit +(defclass indexing-record () + ((slots :accessor indexing-record-slots :initarg :slots :initform nil) + (derived-count :accessor indexing-record-derived :initarg :derived :initform 0))) + +(defmethod print-object ((obj indexing-record) stream) + (format stream "#INDEXING-RECORD<islt: ~A dslt: ~A>" + (length (indexing-record-slots obj)) + (length (indexing-record-derived obj)))) + +(defmethod indexed-record ((class standard-class)) + nil) +(defmethod indexed-record ((class persistent-metaclass)) + (car (%indexed-slots class))) + +(defmethod old-indexed-record ((class persistent-metaclass)) + (cdr (%indexed-slots class))) + +(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) + (let ((oldrec (if (slot-boundp class '%indexed-slots) + (indexed-record class) + nil))) + (setf (%indexed-slots class) + (cons (make-instance 'indexing-record + :slots new-slot-list + :derived (when oldrec (indexing-record-derived oldrec))) + (if oldrec oldrec nil))))) + +(defun indexed-slot-names-from-defs (class) + (let ((slot-definitions (class-slots class))) + (loop for slot-definition in slot-definitions + when (and (subtypep (type-of slot-definition) 'persistent-slot-definition) + (indexed slot-definition)) + collect (slot-definition-name slot-definition)))) + +(defmethod register-indexed-slot ((class persistent-metaclass) slot) + "This method allows for post-definition update of indexed status of + class slots. It changes the effective method so we can rely on + generic function dispatch for differentated behavior" + ;; update record + (let ((record (indexed-record class))) + (unless (member slot (car (%persistent-slots class))) + (error "Tried to register slot ~A as index which isn't a persistent slot" slot)) + (unless (member slot (indexing-record-slots record)) +;; This is a normal startup case, but during other cases we'd like +;; the duplicate warning +;; (warn "Tried to index slot ~A which is already indexed" slot)) + (push slot (indexing-record-slots record)))) + ;; change effective slot def + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) t))) + +(defmethod unregister-indexed-slot (class slot) + "Revert an indexed slot to it's original state" + ;; update record + (let ((record (indexed-record class))) + (unless (member slot (indexing-record-slots record)) + (error "Tried to unregister slot ~A which is not indexed" slot)) + (setf (indexing-record-slots record) (remove slot (indexing-record-slots record)))) + ;; change effective slot def status + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) nil))) + +(defmethod register-derived-index (class name) + "Tell the class that it has derived indices defined against it + and keep a reference count" + (let ((record (indexed-record class))) + (push name (indexing-record-derived record)))) + +(defmethod unregister-derived-index (class name) + (let ((record (indexed-record class))) + (setf (indexing-record-derived record) (remove name (indexing-record-derived record))))) + +(defmethod indexed ((class persistent-metaclass)) + (and (slot-boundp class '%indexed-slots ) + (or (indexing-record-slots (indexed-record class)) + (indexing-record-derived (indexed-record class))))) + +(defmethod indexed ((slot standard-slot-definition)) nil) +(defmethod indexed ((class standard-class)) nil) + +(defvar *inhibit-indexing-list* nil + "Use this to avoid updating an index inside + low-level functions that update groups of + slots at once. We may need to rethink this + if we go to a cheaper form of update that + doesn't batch update all indices") + +(defun inhibit-indexing (uid) + (pushnew uid *inhibit-indexing-list*)) + +(defun uninhibit-indexing (uid) + (setf *inhibit-indexing-list* + (delete uid *inhibit-indexing-list*))) + +;; +;; Original support for persistent slot protocol +;; + #+allegro (defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) '(:instance :class :database)) @@ -128,12 +245,16 @@ "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))) + (transient-p (getf initargs :transient)) + (indexed-p (getf initargs :indexed))) (when (consp transient-p) (setq transient-p (car transient-p))) + (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and (eq allocation-key :class) transient-p) (find-class 'transient-direct-slot-definition)) ((and (eq allocation-key :class) (not transient-p)) (error "Persistent class slots are not supported, try :transient t.")) + ((and indexed-p transient-p) + (error "Cannot declare slots to be both transient and indexed")) (transient-p (find-class 'transient-direct-slot-definition)) (t @@ -161,9 +282,13 @@ (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))) + (let ((transient-p (getf initargs :transient)) + (indexed-p (getf initargs :indexed))) (when (consp transient-p) (setq transient-p (car transient-p))) - (cond (transient-p + (when (consp indexed-p) (setq indexed-p (car indexed-p))) + (cond ((and indexed-p transient-p) + (error "Cannot declare a slot to be both indexed and transient")) + (transient-p (find-class 'transient-effective-slot-definition)) (t (find-class 'persistent-effective-slot-definition))))) @@ -213,11 +338,13 @@ (defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions) (let ((initargs (call-next-method))) (if (ensure-transient-chain slot-definitions initargs) - (append initargs '(:transient t)) - (progn - (setf (getf initargs :allocation) :database) - initargs)))) - + (setf initargs (append initargs '(:transient t))) + (setf (getf initargs :allocation) :database)) + ;; Effective slots are indexed only if the most recent slot definition + ;; is indexed. NOTE: Need to think more about inherited indexed slots + (if (indexed (first slot-definitions)) + (append initargs '(:indexed t)) + initargs)))

(defmacro persistent-slot-reader (instance name) `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance))) @@ -229,7 +356,7 @@ (let ((buf (db-get-key-buffered (controller-db (check-con (:dbcn-spc-pst ,instance))) key-buf value-buf))) - (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst instance))) + (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst ,instance))) #+cmu (error 'unbound-slot :instance ,instance :slot ,name) #-cmu @@ -301,7 +428,7 @@ (defun persistent-slot-names (class) (let ((slot-definitions (class-slots class))) (loop for slot-definition in slot-definitions - when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) + when (subtypep (type-of slot-definition) 'persistent-effective-slot-definition) collect (slot-definition-name slot-definition))))

(defun transient-slot-names (class) --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/04 22:25:09 1.18 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/07 23:23:51 1.19 @@ -102,8 +102,8 @@

(eval-when (:compile-toplevel :load-toplevel) (defparameter *c-library-extension* - #+macosx "dylib" - #-macosx "so" )) + #+(or darwin macosx) "dylib" + #-(or darwin macosx) "so" ))

(eval-when (:compile-toplevel :load-toplevel)

--- /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/02/04 22:25:09 1.3 +++ /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/02/07 23:23:51 1.4 @@ -25,7 +25,6 @@ (:metaclass persistent-metaclass) (:documentation "A SQL-based BTree supports secondary indices."))

- (defmethod get-value (key (bt sql-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3)))