[elephant-cvs] CVS elephant/src/contrib/eslick

[ieslick]

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick
In directory clnet:/tmp/cvs-serv12311/src/contrib/eslick

Added Files:
	tools.lisp 
Log Message:

Significant additions to the 0.6.0 release on the trunk.  Updates to 
documentation, 0.5.0 compliance, final on 0.6.0 features.  There are
one or two BDB interactions on migration to work out but this should
be a nearly code complete 0.6.0 release.  Please start testing and
evaluating this - especially the ability to open and tag 0.5.0 databases.

Features:
- Database version tagging
- Support for 0.5.0 namespaces & databases
- New migration system
- class indexing without slot indexing
- various bug fixes
- reverted fast allegro/sbcl string support to
  allow 0.5.0 databases to work correctly.  I 
  couldn't find a good way to work around this
  without creating infinite headaches
- validated that running db_deadlock will stop all
  lisp freezes that I've encountered.  This has to
  be run each time a DB environment is opened/created
  so eventually should be made part of the open-controller
  functionality for the BDB backend




--- /project/elephant/cvsroot/elephant/src/contrib/eslick/tools.lisp	2006/04/26 17:53:44	NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/tools.lisp	2006/04/26 17:53:44	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; tools.lisp -- use btree collections to track objects by slot values
;;;                  via metaclass options or accessor :after methods
;;; 
;;; Initial version 3/29/2006 Ian Eslick
;;; eslick at alum mit edu
;;;
;;; License: Lisp Limited General Public License (LLGPL)
;;; http://www.franz.com/preamble.html
;;;

(in-package :elephant)

;;
;; Messy method to see what's in a btree
;;

(defmethod summarize-btree-contents ((btree btree) &key (print-depth 100) (search-depth nil) (dump nil) (recurse nil))
  (let ((count 0)
	(record (make-btree-summary-record)))
    (catch 'max-depth 
      (map-btree (lambda (key val)
		   (incf count)
		   (when (and search-depth (> count search-depth))
		     (throw 'max-depth nil))
		   (update-stats-for-value val record)
		   (when (and dump (< count print-depth))
		     (format t "key: ~A  value: ~A~%" key val))
		   (when (and recurse (subtypep (type-of val) 'btree) (< count print-depth))
		     (format t "Recursing into ~A:~A...~%" key val)
		     (summarize-btree-contents val :search-depth search-depth :print-depth print-depth 
					       :dump dump :recurse recurse)
		     (format t "...completing recursion into ~A:~A~%" key val)))
		 btree))
    (format t "Summary:~%")
    (loop for pair in record do
	 (cond ((eq (car pair) 'array)
		(format t "~A (~A)~%" (symbol-name (car pair)) (- (cdr pair) (cdr (assoc 'string record)))))
	       (t (format t "~A (~A)~%" (symbol-name (car pair)) (cdr pair)))))))

(defparameter *base-types*
  '(persistent-object
    persistent-collection
    structure-object
    standard-object
    number
    string
    array
    hash-table))
    
(defun make-btree-summary-record ()
  (let ((record nil))
    (loop for type in *base-types* do
	 (push (cons (intern type (find-package 'keyword)) 0)
	       record))
    record))

(defmethod update-stats-for-value (value record)
  (loop for type in *base-types* do
       (when (subtypep (type-of value) type)
	 (incf (cdr (assoc (intern type (find-package 'keyword)) record))))))