[elephant-cvs] CVS elephant/src
rread
rread at common-lisp.net
Tue Feb 7 23:23:51 UTC 2006
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*))
, at 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 , at 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 , at 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)))
More information about the Elephant-cvs
mailing list