[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Fri Apr 27 13:32:28 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv32343/src/elephant
Modified Files:
classes.lisp collections.lisp package.lisp query.lisp
transactions.lisp
Log Message:
Bug fixes to change-class; drop-btree; enable :from-end and :collect on map-btree (not map-class though); export and documentation edits
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/04/25 02:28:01 1.32
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/04/27 13:32:16 1.33
@@ -185,13 +185,17 @@
;; CLASS CHANGE PROTOCOL
;;
-(defmethod change-class ((inst persistent) (class t) &rest rest)
- (cerror "Ignore and continue?"
- "Changing a persistent instance's class to a non-persistent class is not currently allowed"))
-
-(defmethod change-class ((inst standard-object) (class persistent-metaclass) &rest rest)
- (cerror "Ignore and continue?"
- "Changing a standard instance to a persistent instance is not supported"))
+(defmethod change-class :around ((previous persistent) (new-class standard-class) &rest initargs)
+ (declare (ignorable initargs))
+ (unless (subtypep (type-of new-class) 'persistent-metaclass)
+ (error "Persistent instances cannot be changed to non-persistent classes in change-class"))
+ (call-next-method))
+
+(defmethod change-class :around ((previous standard-object) (new-class persistent-metaclass) &rest initargs)
+ (declare (ignorable initargs))
+ (unless (subtypep (type-of previous) 'persistent)
+ (error "Standard classes cannot be changed to non-persistent classes in change-class"))
+ (call-next-method))
(defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key)
(let* ((old-class (class-of previous))
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/04/25 02:28:01 1.26
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/04/27 13:32:17 1.27
@@ -70,6 +70,18 @@
(defmethod optimize-layout ((bt t) &key &allow-other-keys)
t)
+(defgeneric drop-btree (bt)
+ (:documentation "Delete all key-value pairs from the btree and
+ render it an invalid object in the data store"))
+
+(defmethod drop-btree ((bt btree))
+ (ensure-transaction (:store-controller *store-controller*)
+ (with-btree-cursor (cur bt)
+ (loop for (exists? key) = (multiple-value-list (cursor-first cur))
+ then (multiple-value-list (cursor-next cur))
+ while exists?
+ do (remove-kv key bt)))))
+
;;
;; Btrees that support secondary indices
;;
@@ -161,17 +173,17 @@
(defclass cursor ()
((oid :accessor cursor-oid :type fixnum :initarg :oid)
-;; (intialized-p cursor) means that the cursor has
-;; a legitimate position, not that any initialization
-;; action has been taken. The implementors of this abstract class
-;; should make sure that happens under the sheets...
-;; According to my understanding, cursors are initialized
-;; when you invoke an operation that sets them to something
-;; (such as cursor-first), and are uninitialized if you
-;; move them in such a way that they no longer have a legimtimate
-;; value.
(initialized-p :accessor cursor-initialized-p
- :type boolean :initform nil :initarg :initialized-p)
+ :type boolean :initform nil :initarg :initialized-p
+ :documentation "Predicate indicating whether
+the btree in question is initialized or not. Initialized means
+that the cursor has a legitimate position, not that any
+initialization action has been taken. The implementors of this
+abstract class should make sure that happens under the
+sheets... Cursors are initialized when you invoke an operation
+that sets them to something (such as cursor-first), and are
+uninitialized if you move them in such a way that they no longer
+have a legimtimate value.")
(btree :accessor cursor-btree :initarg :btree))
(:documentation "A cursor for traversing (primary) BTrees."))
@@ -240,13 +252,13 @@
(defgeneric cursor-delete (cursor)
(:documentation
- "Delete by cursor. The cursor is at an invalid position
-after a successful delete."))
+ "Delete by cursor. The cursor is at an invalid position,
+and uninitialized, after a successful delete."))
(defgeneric cursor-put (cursor value &key key)
(:documentation
- "Put by cursor. Currently doesn't properly move the
-cursor."))
+ "Overwrite value at current cursor location. Currently does
+ not properly move the cursor."))
(defclass secondary-cursor (cursor) ()
(:documentation "Cursor for traversing secondary indices."))
@@ -354,7 +366,7 @@
(defun lisp-compare-equal (a b)
(equal a b))
-(defgeneric map-btree (fn btree &rest args &key start end value &allow-other-keys)
+(defgeneric map-btree (fn btree &rest args &key start end value from-end collect &allow-other-keys)
(:documentation "Map btree maps over a btree from the value start to the value of end.
If values are not provided, then it maps over all values. BTrees
do not have duplicates, but map-btree can also be used with indices
@@ -365,26 +377,47 @@
;; function orders by type tag and nil is the highest valued type tag so nils are the last
;; possible element in a btree ordered by value.
-(defmethod map-btree (fn (btree btree) &rest args &key start end (value nil value-set-p) &allow-other-keys)
- (let ((end (if value-set-p value end)))
+(defmethod map-btree (fn (btree btree) &rest args &key start end (value nil value-set-p)
+ from-end collect &allow-other-keys)
+ (let ((end (if value-set-p value end))
+ (results nil))
(ensure-transaction (:store-controller (get-con btree) :degree-2 *map-using-degree2*)
(with-btree-cursor (curs btree)
- (multiple-value-bind (exists? key value)
- (cond (value-set-p
- (cursor-set curs value))
- ((null start)
- (cursor-first curs))
- (t (cursor-set-range curs start)))
- (if exists?
- (funcall fn key value)
- (return-from map-btree nil))
- (loop
- (multiple-value-bind (exists? k v)
- (cursor-next curs)
- (declare (dynamic-extent exists? k v))
- (if (and exists? (or (null end) (lisp-compare<= k end)))
- (funcall fn k v)
- (return nil)))))))))
+ (flet ((continue-p (key)
+ ;; Do we go to the next value?
+ (or (if from-end (null start) (null end))
+ (if from-end
+ (or (not (lisp-compare<= key start))
+ (lisp-compare-equal key start))
+ (lisp-compare<= key end))))
+ (collector (k v)
+ (push (funcall fn k v) results)))
+ (let ((fn (if collect #'collector fn)))
+ (declare (dynamic-extent (function continue-p) (function collector)))
+ (multiple-value-bind (exists? key value)
+ (cond (value-set-p
+ (cursor-set curs value))
+ ((and (not from-end) (null start))
+ (cursor-first curs))
+ ((and from-end (null end))
+ (cursor-last curs))
+ (t (if from-end
+ (cursor-set-range curs end)
+ (cursor-set-range curs start))))
+ (declare (dynamic-extent exists? k v))
+ (if exists?
+ (funcall fn key value)
+ (return-from map-btree nil))
+ (loop
+ (multiple-value-bind (exists? k v)
+ (if from-end
+ (cursor-prev curs)
+ (cursor-next curs))
+ (declare (dynamic-extent exists? k v))
+ (if (and exists? (continue-p k))
+ (funcall fn k v)
+ (return nil)))))))))
+ results))
(defgeneric map-index (fn index &rest args &key start end value from-end collect &allow-other-keys)
(:documentation "Map-index is like map-btree but for secondary indices, it
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/04/25 02:28:02 1.33
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/04/27 13:32:17 1.34
@@ -216,12 +216,11 @@
#:btree-index
#:add-index #:get-index #:remove-index #:map-indices
#:get-primary-key #:primary #:key-form #:key-fn
- #:with-btree-cursor #:map-btree #:map-index
+ #:with-btree-cursor #:map-btree #:map-index #:drop-btree
#:empty-btree-p #:dump-btree #:btree-keys #:btree-differ-p
#:cursor #:secondary-cursor #:make-cursor #:make-simple-cursor
- #:cursor-close #:cursor-init
- #:cursor-duplicate #:cursor-current #:cursor-first
+ #:cursor-close #:cursor-duplicate #:cursor-current #:cursor-first
#:cursor-last #:cursor-next #:cursor-next-dup
#:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup
#:cursor-set #:cursor-set-range #:cursor-get-both
@@ -229,8 +228,8 @@
#:cursor-pcurrent #:cursor-pfirst #:cursor-plast
#:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup
#:cursor-pprev #:cursor-pprev-nodup #:cursor-pset
- #:cursor-pset-range #:cursor-pget-both
- #:cursor-pget-both-range
+ #:cursor-pset-range #:cursor-pget-both #:cursor-pget-both-range
+ #:cursor-initialized-p
#:find-class-index #:find-inverted-index
#:enable-class-indexing #:disable-class-indexing
@@ -240,7 +239,7 @@
#:report-indexed-classes
#:class-indexedp-by-name
- #:map-class #:map-class-index
+ #:map-class #:map-inverted-index
#:get-instances-by-class
#:get-instance-by-value
#:get-instances-by-value
--- /project/elephant/cvsroot/elephant/src/elephant/query.lisp 2007/04/12 02:47:33 1.4
+++ /project/elephant/cvsroot/elephant/src/elephant/query.lisp 2007/04/27 13:32:17 1.5
@@ -73,8 +73,8 @@
(if (find-inverted-index class slot)
(if (= (length values) 1)
(progn
- (map-class-index fn class slot (first values) (first values))
- (map-class-index fn class slot (first values) (second values))))
+ (map-inverted-index fn class slot (first values) (first values))
+ (map-inverted-index fn class slot (first values) (second values))))
(map-class #'filter-by-relation class))
(map-class-query #'filter-by-relation (cdr constraints))))))
--- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/04/12 02:47:33 1.11
+++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/04/27 13:32:17 1.12
@@ -95,13 +95,18 @@
;; form))
(defun transaction-object-p (txnrec)
- (consp txnrec))
+ (and (not (null txnrec))
+ (consp txnrec)
+ (subtypep (type-of (car txnrec)) 'store-controller)))
(defun owned-txn-p (sc parent-txn-rec)
(and parent-txn-rec
(transaction-object-p parent-txn-rec)
(eq sc (transaction-store parent-txn-rec))))
+(define-condition transaction-retry-count-exceeded ()
+ ((retry-count :initarg :count)))
+
(defmacro with-transaction ((&rest keyargs &key
(store-controller '*store-controller*)
(parent '*current-transaction*)
@@ -126,7 +131,7 @@
(defmacro ensure-transaction ((&rest keyargs &key
(store-controller '*store-controller*)
- (transaction '*current-transaction*)
+ (parent '*current-transaction*)
(retries 200)
&allow-other-keys)
&body body)
@@ -139,7 +144,7 @@
(sc (gensym)))
`(let ((,txn-fn (lambda () , at body))
(,sc ,store-controller))
- (if (owned-txn-p ,sc ,transaction)
+ (if (owned-txn-p ,sc ,parent)
(funcall ,txn-fn)
(funcall #'execute-transaction ,store-controller
,txn-fn
More information about the Elephant-cvs
mailing list