Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv13701/src/elephant

Modified Files: classindex.lisp collections.lisp package.lisp Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations

--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/18 23:38:18 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 19:12:58 1.19 @@ -345,35 +345,56 @@ (cursor-close ,var))))

-;; ========================= -;; User-level lisp API -;; ========================= +;; ==================================== +;; User level Mapping API +;; ==================================== + +(defun map-class (fn class) + "Perform a map operation across all instances of class. Takes a + function of one argument, the class instance" + (let* ((class (if (symbolp class) + (find-class class) + class)) + (class-idx (find-class-index class))) + (flet ((map-fn (k v) + (declare (ignore k)) + (funcall fn v))) + (declare (dynamic-extent map-fn)) + (map-btree #'map-fn class-idx)))) + +(defun map-instances (fn class index start end) + "If you want to map over a subset of instances, pick an index + and specify bounds for the traversal. Otherwise use map-class + for all instances" + (let* ((index (if (symbolp index) + (find-inverted-index class index) + index))) + (flet ((wrapper (key value pkey) + (declare (ignore key pkey)) + (funcall fn value))) + (declare (dynamic-extent wrapper)) + (map-index #'wrapper index :start start :end end)))) + + +;; =============================== +;; User-level LIST-oriented API +;; ===============================

(defgeneric get-instances-by-class (persistent-metaclass)) (defgeneric get-instance-by-value (persistent-metaclass slot-name value)) (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))))))))) + (let ((instances nil)) + (flet ((accum (c) + (declare (dynamic-extent c)) + (push c instances))) + (map-class #'accum class) + (nreverse instances))))

(defmethod get-instances-by-value ((class symbol) slot-name value) (get-instances-by-value (find-class class) slot-name value)) @@ -381,17 +402,14 @@ (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) (declare (type (or string symbol) slot-name)) (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))))))))) + (declare (type list instances)) + (flet ((collector (k v pk) + (declare (ignore k pk)) + (push v instances))) + (declare (dynamic-extent collector)) + (map-index #'collector (find-inverted-index class slot-name) + :start value :end value)) + (nreverse instances)))

(defmethod get-instance-by-value ((class symbol) slot-name value) (let ((list (get-instances-by-value (find-class class) slot-name value))) @@ -409,27 +427,16 @@ (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) (declare (type fixnum start end) (type string idx-name)) - (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))))) - + (let ((instances nil)) + (declare (type list instances)) + (flet ((collector (k v pk) + (declare (ignore k pk)) + (push v instances))) + (declare (dynamic-extent collector)) + (map-index #'collector (find-inverted-index class idx-name) + :start start :end end)) + (nreverse instances))) + (defun drop-instances (instances &key (sc *store-controller*)) (when instances (assert (consp instances)) @@ -440,5 +447,3 @@ (drop-pobject instance)) subset)))))

- - --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/16 07:11:02 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/20 19:12:58 1.10 @@ -314,27 +314,71 @@ primary key."))

-;; -;; Some generic utility functions -;; +;; ======================================= +;; Generic Mapping Functions +;; =======================================

(defmacro with-btree-cursor ((var bt) &body body) "Macro which opens a named cursor on a BTree (primary or not), evaluates the forms, then closes the cursor." `(let ((,var (make-cursor ,bt))) - (unwind-protect - (progn ,@body) - (cursor-close ,var)))) + (unwind-protect + (progn ,@body) + (cursor-close ,var))))

(defmethod map-btree (fn (btree btree)) - "Like maphash. Default implementation - overridable" - (with-transaction (:store-controller (get-con btree)) + "Like maphash. Default implementation - overridable + Function of two arguments key and value" + (ensure-transaction (:store-controller (get-con btree)) (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) + (declare (dynamic-extent more k v)) (unless more (return nil)) (funcall fn k v))))))

+(defmethod map-index (fn (index btree-index) &rest args &key start end) + "Like map-btree, but takes a function of three arguments key, value and primary key + if you want to get at the primary key value, otherwise use map-btree" + (declare (dynamic-extent args)) + (let ((sc (get-con index))) + (ensure-transaction (:store-controller sc) + (with-btree-cursor (cur index) + (labels ((next-range () + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) + (if (or (and exists? (not end)) + (and exists? (<= skey end))) + (progn + (funcall fn skey val pkey) + (next-in-range skey)) + (return-from map-index nil)))) + (next-in-range (key) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (if exists? + (progn + (funcall fn skey val pkey) + (next-in-range key)) + (progn + (cursor-pset-range cur key) + (next-range)))))) + (declare (dynamic-extent next-range next-in-range)) + (multiple-value-bind (exists? skey val pkey) + (if start + (cursor-pset-range cur start) + (cursor-pfirst cur)) + (if (or (and exists? (not end)) + (and exists? (<= skey end))) + (progn + (funcall fn skey val pkey) + (next-in-range skey)) + nil))))))) + + + +;; =============================== +;; Some generic utility functions +;; =============================== + (defmethod empty-btree-p ((btree btree)) (ensure-transaction (:store-controller (get-con btree)) (with-btree-cursor (cur btree) @@ -345,10 +389,9 @@ (eq k *elephant-properties-label*)) ;; has properties (not (cursor-next cur))) (t nil)))))) -

-(defun print-btree-node (k v) - (format t "k ~A / v ~A~%" k v)) +(defun print-btree-entry (k v) + (format t "key: ~A / value: ~A~%" k v))

(defun dump-btree (bt &key (print-fn #'print-btree-node) (count nil)) "Print the contents of a btree for easy inspection & debugging" @@ -361,13 +404,16 @@ (funcall print-fn k v)) bt)))

-(defun btree-keys (bt) - (format t "BTREE keys for ~A~%" bt) - (map-btree #'(lambda (k v) - (format t "key ~A / value type ~A~%" k (type-of v))) - bt)) +(defun print-btree-key-and-type (k v) + (format t "key ~A / value type ~A~%" k (type-of v)))

-(defun btree-differ (x y) +(defun btree-keys (bt &key (print-fn #'print-btree-key-and-type) (count nil)) + (format t "BTREE keys and types for ~A~%" bt) + (dump-btree bt :print-fn print-fn :count count)) + +(defmethod btree-differ-p ((x btree) (y btree)) + (assert (eq (get-con x) (get-con y))) + (ensure-transaction (:store-controller (get-con x)) (let ((cx1 (make-cursor x)) (cy1 (make-cursor y)) (done nil) @@ -402,4 +448,4 @@ (cursor-close cx1) (cursor-close cy1) rv - )) + ))) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/16 07:11:02 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/20 19:12:58 1.15 @@ -55,7 +55,7 @@ #:persistent #:persistent-object #:persistent-metaclass #:persistent-collection #:defpclass

- #:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree + #:btree #:make-btree #:get-value #:remove-kv #:existp #:indexed-btree #:make-indexed-btree #:add-index #:get-index #:remove-index #:map-indices #:btree-index #:get-primary-key @@ -69,7 +69,7 @@ #:int-byte-spec

#:cursor #:secondary-cursor #:make-cursor - #:with-btree-cursor #:cursor-close #:cursor-init + #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup @@ -95,6 +95,21 @@ #:make-inverted-cursor #:make-class-cursor #:with-inverted-cursor #:with-class-cursor

+ ;; Primitive mapping API + #:with-btree-cursor + #:map-btree + #:map-index + + ;; BTREE Utilities + #:empty-btree-p + #:dump-btree + #:btree-keys + #:btree-differ-p + + ;; Class mapping API + #:map-class + #:map-instances + ;; Instance query API #:get-instances-by-class #:get-instance-by-value