[elephant-cvs] CVS elephant/src/db-acache

[ieslick]

Update of /project/elephant/cvsroot/elephant/src/db-acache
In directory common-lisp:/tmp/cvs-serv10634/src/db-acache

Added Files:
	README acache-collections.lisp acache-controller.lisp 
	acache-transactions.lisp package.lisp 
Log Message:
A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work


--- /project/elephant/cvsroot/elephant/src/db-acache/README	2006/02/20 21:21:41	NONE
+++ /project/elephant/cvsroot/elephant/src/db-acache/README	2006/02/20 21:21:41	1.1


This directory contains a quick and dirty sketch of an allegrocache
backend, mostly to test out the new backend abstraction.  Too bad we 
can't use allegroserve directly behind the metaclass protocol...the 
apis are a little too different for that.
--- /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp	2006/02/20 21:21:41	NONE
+++ /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp	2006/02/20 21:21:41	1.1


(in-package :elephant-acache)

;; BTREE

(defclass acache-btree (btree) ())

(defmethod build-btree ((sc acache-store-controller))
  (make-instance 'acache-btree :sc sc))

(defmethod get-value (key (bt acache-btree))
  (map-value (controller-btrees (get-con bt)) (cons (oid bt) key)))

(defmethod (setf get-value) (value key (bt acache-btree))
  (setf (map-value (controller-btrees (get-con bt)) (cons (oid bt) key))
	value))

(defmethod existsp (key (bt acache-btree))
  (when (get-value key bt)
    t))

(defmethod remove-kv (key (bt acache-btree))
  (remove-from-map (controller-btrees (get-con bt)) (cons (oid bt) key)))

(defmethod map-btree (fn (bt acache-btree))
  (map-map fn bt))

;;
;; Cursors need to have their own model of where they are
;;

;; INDEXED BTREE

;; How to handle add-index?  Have to hack it up on btrees just like slot
;; values...which means solving the complex key problem--- /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp	2006/02/20 21:21:41	NONE
+++ /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp	2006/02/20 21:21:41	1.1

(in-package :elephant-acache)

(defclass acache-store-controller (store-controller)
  ((db :accessor controller-db :initform nil)
   (slots :accessor controller-slots :initform nil)
   (btrees :accessor controller-btrees :initform nil)
   (oidrec :accessor controller-oidrec :initform nil)))

(defun acache-constructor (spec)
  (make-instance 'acache-store-controller :spec spec))

(eval-when (:compile-toplevel :load-toplevel)
  (register-backend-con-init :acache 'acache-constructor))

(defclass oid-record ()
  ((counter :accessor oid-record-counter :initform 0))
  (:metaclass db.allegrocache:persistent-class))

(defmethod open-controller ((sc acache-store-controller) &key (recover t)
			    (recover-fatal nil) (thread nil))
  (declare (ignore recover thread recover-fatal))
  (let ((db (db.allegrocache:open-file-database (second (controller-spec sc))
						 :if-does-not-exist :create
						 :if-exists :open
						 :use :memory)))
    (when (not db)
      (error "Unable to open astore database for ~A" (controller-spec sc)))
    ;; Main DB ref
    (setf (controller-db sc) db)
    ;; Slots and Btree storage
    (let ((slotmap (retrieve-from-index 'ac-map 'ac-map-name "slots")))
      (setf (controller-slots sc) 
	    (if slotmap slotmap
		(make-instance 'db.allegrocache:ac-map :ac-map-name "slots"))))
    (let ((btreemap (retrieve-from-index 'ac-map 'ac-map-name "btrees")))
      (setf (controller-btrees sc) 
	    (if btreemap btreemap
		(make-instance 'db.allegrocache:ac-map :ac-map-name "btrees"))))
    ;; OIDS
    (let ((oidrec (doclass (inst (find-class 'oid-record) :db db)
		    (when inst (return inst)))))
      (setf (controller-oidrec sc)
	    (if oidrec
		oidrec
		(make-instance 'oid-record))))
    ;; Construct the roots
    (setf (slot-value sc 'root) (make-instance 'acache-btree :from-oid -1))
    (setf (slot-value sc 'class-root) (make-instance 'acache-btree :from-oid -2))
    sc))
    
    
(defmethod next-oid ((sc acache-store-controller))
  (db.allegrocache:with-transaction-restart ()
    (incf (oid-record-counter (controller-oidrec sc)))
    (commit)))

(defmethod close-controller ((sc acache-store-controller))
  ;; Ensure deletion of common
  (setf (slot-value sc 'class-root) nil)
  (setf (slot-value sc 'root) nil)
  (db.allegrocache:close-database :db (controller-db sc)))

(defmethod connection-is-indeed-open ((sc acache-store-controller))
  (db.allegrocache::database-open-p (controller-db sc)))

;; Slot writing

;; This is not thread-safe, but could be a thread-local when we fix that...
;; to avoid extra consing.  Is consing less/more expensive than dynamic
;; var lookups?

(defvar *index-cons* (cons nil nil))

(defmacro fast-key (oid name)
  `(rplacd (rplaca *index-cons* ,oid) ,name))

(defmethod persistent-slot-reader ((sc acache-store-controller) instance name)
  (declare (optimize (speed 3) (safety 1)))
  (multiple-value-bind (val valid?) (map-value (controller-slots sc) (fast-key (oid instance) name))
    (if valid?
	val
	(error "Slot ~A unbound in ~A" name instance))))

(defmethod persistent-slot-writer ((sc acache-store-controller) value instance name)
  (declare (optimize (speed 3) (safety 1)))
  (setf (map-value (controller-slots sc) (fast-key (oid instance) name))
	value))

(defmethod persistent-slot-boundp ((sc acache-store-controller) instance name)
  (declare (optimize (speed 3) (safety 1)))
  (when (map-value (controller-slots sc) (fast-key (oid instance) name))
    t))

(defmethod persistent-slot-makunbound ((sc acache-store-controller) instance name)
  (declare (optimize (speed 3) (safety 1)))
  (remove-from-map (controller-slots sc) (fast-key (oid instance) name)))

--- /project/elephant/cvsroot/elephant/src/db-acache/acache-transactions.lisp	2006/02/20 21:21:41	NONE
+++ /project/elephant/cvsroot/elephant/src/db-acache/acache-transactions.lisp	2006/02/20 21:21:41	1.1


(in-package :elephant-acache)

(defmethod controller-start-transaction ((sc acache-store-controller) &key parent &allow-other-keys)
  "Allegrocache has implicit transactions whenever there's a write"
  (when parent
    (error "ACache backend does not allow nested transactions...a commit will commit everything
            since the last commit"))
  t)

(defmethod controller-commit-transaction ((sc acache-store-controller) &key &allow-other-keys)
  (db.allegrocache:commit :db (controller-db sc)))

(defmethod controller-abort-transaction ((sc acache-store-controller) &key &allow-other-keys)
  (db.allegrocache:rollback :db (controller-db sc)))

(defmethod execute-transaction ((sc acache-store-controller) closure &key parent retries &allow-other-keys)
  (db.allegrocache:with-transaction-restart (:count retries)
    (funcall closure)
    (db.allegrocache:commit :db sc)))--- /project/elephant/cvsroot/elephant/src/db-acache/package.lisp	2006/02/20 21:21:41	NONE
+++ /project/elephant/cvsroot/elephant/src/db-acache/package.lisp	2006/02/20 21:21:41	1.1


(in-package :cl-user)

(eval-when (:load-toplevel :compile-toplevel)
  (require :acache))

(eval-when (:load-toplevel)
  (warn "Allegrocache support is incomplete and should be considered as an example only"))

(defpackage elephant-acache
  (:documentation "A low-level UFFI-based interface to
   Berkeley DB / Sleepycat to implement the elephant front-end
   framework.  Uses the libsleepycat.c wrapper.  Partly intended 
   to be usable outside Elephant, but with some magic for Elephant.  
   In general there is a 1-1 mapping from functions here and 
   functions in Sleepycat, so refer to their documentation for details.")
  (:use common-lisp elephant elephant-backend)
  (:import-from #:db.allegrocache
		#:ac-map
		#:ac-map-name
		#:doclass
		#:commit
		#:retrieve-from-index
		#:map-map
		#:map-value
		#:remove-from-map))