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 () ,@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