[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp
ieslick
ieslick at common-lisp.net
Mon Feb 12 20:36:45 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp
In directory clnet:/tmp/cvs-serv5382/src/contrib/eslick/db-lisp
Modified Files:
TODO btree.lisp file.lisp package.lisp pages.lisp
Added Files:
ele-lisp.asd log.lisp
Removed Files:
lisp-types.lisp octet-stream.lisp serializer3.lisp
Log Message:
Henrik's fixes and latest db-lisp updates
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/08 15:57:19 1.2
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/12 20:36:44 1.3
@@ -1,4 +1,23 @@
+Active TODO:
+- secondary indices
+- lisp-based comparison function for serialized streams
+- variable size keys and values
+- transaction logging and transactions
+- page-level locks
+ (transactions are used to mark page-level rd/wr locks)
+ (on commit, transaction conflicts cause a transaction abort to be issued to appropriate threads)
+ (each transaction op can signal an abort condition)
+ (how to lock pages?)
+
+- direct serialization to lisp array (avoid memutil copy)
+- utilities for recovery, checkpointing, etc
+
+- large sets of objects
+- inverted index
+
+=========================
+
High level lisp backend design:
- Page storage, layout policy; lisp array or foreign data?
- key length limits
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 23:05:46 1.3
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/12 20:36:44 1.4
@@ -1,13 +1,41 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend
+;;;
+;;; part of
+;;;
+;;; Elephant Object Oriented Database: Common Lisp Backend
+;;;
+;;; Copyright (c) 2007 by Ian Eslick
+;;; <ieslick at common-lisp.net>
+;;;
+;;; Elephant Lisp Backend users are granted the rights to distribute
+;;; and use this software as governed by the terms of the Lisp Lesser
+;;; GNU Public License (http://opensource.franz.com/preamble.html),
+;;; also known as the LLGPL.
+
(in-package :db-lisp)
+(defparameter *btree-page-size* 8192
+ "The size of a btree page. 8192 leaves room for 32
+ key/value pairs (@ 256 bytes /ea)")
+(defparameter *btree-cache-size* 2048
+ "The number of cache pages to allocate (4k pages at
+ 4k /ea - 16MB working set)")
+
+;;
;; Data layout
;; - page types: index, leaf, blobs
+;;
+
+(defparameter *db-version* 1)
(defparameter *type-table*
- '((0 . :unknown)
+ '((0 . :free)
(1 . :index)
(2 . :leaf)
(3 . :overflow)
+ (#xFE . :root-as-leaf)
(#xFF . :root)))
(defun get-type (byte)
@@ -15,58 +43,490 @@
(cdr (assoc byte *type-table*)))
(defun get-type-id (type-symbol)
- (loop for (id symbol) in *type-table* do
+ (loop for (id . symbol) in *type-table* do
(when (eq type-symbol symbol)
(return id))
finally (error "Invalid page type identifier")))
;;
-;; Read/Write references
+;; Byte fields
+;;
+
+(defun write-field (field page integer)
+ (write-integer integer page (first field) (second field)))
+
+(defun read-field (field page)
+ (read-integer page (first field) (second field)))
+
+(defun write-field-default (field page)
+ (write-field field page (third field)))
+
+(defun verify-field-default (field page)
+ (assert (= (third field) (read-field field page))))
+
+(defmacro def-field (name (start length &optional (default nil)))
+ `(defparameter ,name
+ (list ,start ,length ,default)))
+
+(defmethod field-length (field)
+ (second field))
+
+(defmethod field-start (field)
+ (first field))
+
+;;
+;; Field definitions
+;;
+
+(def-field +page-type+ (0 1))
+
+(defun read-page-type (page)
+ (get-type (read-field +page-type+ page)))
+
+(defun write-page-type (page type)
+ (write-field +page-type+ page (get-type-id type)))
+
+(def-field +free-list-next+ (1 4 0))
+
+(def-field +root-version+ (1 1 *db-version*))
+(def-field +root-reserved+ (2 8 #xDEADBEEFDEADBEEF))
+(def-field +root-alloc-pointer+ (10 4 0))
+(def-field +root-free-pointer+ (14 4 0))
+(def-field +root-last-valid-byte+ (18 3 0))
+(def-field +root-num-keys+ (21 2 0))
+(defconstant +root-key-start+ 23)
+
+(def-field +index-reserved+ (1 8 0))
+(def-field +index-last-valid-byte+ (9 3 0))
+(def-field +index-num-keys+ (12 2 0))
+(defconstant +index-key-start+ 14)
+
+(def-field +leaf-prev+ (1 4 0))
+(def-field +leaf-next+ (5 4 0))
+(def-field +leaf-last-valid-byte+ (9 3 0))
+(def-field +leaf-num-keys+ (12 2 0))
+(defconstant +leaf-key-start+ 14)
+
+(defun leaf-p (page)
+ (or (eq (page-type page) :leaf)
+ (eq (page-type page) :root-as-leaf)))
+
+;;
+;; Initializing btree page types
+;;
+
+(defun initialize-root-page (page)
+ (write-page-type page (setf (page-type page) :root-as-leaf))
+ (write-field-default +root-version+ page)
+ (write-field-default +root-reserved+ page)
+ (write-field-default +root-free-pointer+ page)
+ (write-field-default +root-num-keys+ page))
+
+(defun initialize-index-page (page)
+ (write-page-type page (setf (page-type page) :index))
+ (write-field-default +index-reserved+ page)
+ (write-field-default +index-num-keys+ page))
+
+(defun initialize-leaf-page (page)
+ (write-page-type page (setf (page-type page) :leaf))
+ (write-field-default +leaf-prev+ page)
+ (write-field-default +leaf-next+ page))
+
+(defun initialize-free-page (page)
+ (write-page-type page (setf (page-type page) :free))
+ (write-field-default +free-list-next+ page))
+
+;;
+;; Keys and values
+;;
+
+(defparameter *max-key-size* 255)
+(defparameter *max-value-size* 255)
+
+(defun read-pointer (page offset)
+ (read-integer page offset 4))
+
+(defun write-pointer (page offset pointer)
+ (write-integer pointer page offset 4))
+
+(defmethod extract-key (page offset bs)
+ (let ((klen (read-integer page offset 4)))
+ (values (when (> klen 0) (read-buffer-stream page bs (+ offset 4) klen))
+ (read-pointer page (+ offset klen 4))
+ (+ offset klen 8))))
+
+(defmethod write-key (page offset bs pointer)
+ (let ((klen (buffer-stream-size bs)))
+ (assert (< klen *max-key-size*))
+ (write-integer page offset klen 4)
+ (write-buffer-stream page bs (+ offset 4))
+ (write-pointer page (+ offset (buffer-stream-size bs) 4) pointer)))
+
+(defmethod extract-value (page offset bs)
+ (let ((vlen (read-integer page offset)))
+ (values (when (> vlen 0) (read-buffer-stream page bs (+ offset 4) vlen)) vlen)))
+
+(defmethod write-value (page offset bs)
+ (let ((vlen (buffer-stream-size bs)))
+ (assert (< vlen *max-value-size*))
+ (write-integer page offset vlen 4)
+ (write-buffer-stream page bs offset)))
+
+(defmethod skip-value (page offset)
+ "Returns the offset after the value is consumed"
+ (let ((vlen (read-integer page offset)))
+ (+ offset vlen)))
+
+(defun last-valid-byte (page)
+ "Get the last valid page irrespective of page type"
+ (case (page-type page)
+ (:root (read-field +root-last-valid-byte+ page))
+ (:index (read-field +index-last-valid-byte+ page))
+ (:leaf (read-field +leaf-last-valid-byte+ page))))
+
+(defun set-last-valid-byte (value page)
+ (case (page-type page)
+ (:root (write-field +root-last-valid-byte+ page value))
+ (:index (write-field +index-last-valid-byte+ page value))
+ (:leaf (write-field +leaf-last-valid-byte+ page value))))
+
+(defsetf last-valid-byte set-last-valid-byte)
+
+;;
+;; Comparison functions
+;;
+
+(defun lexical-compare-< (bs1 bs2)
+ "Stub comparison function"
+ (if (= (buffer-stream-size bs1) (buffer-stream-size bs2))
+ (loop for i from 0 below (buffer-stream-size bs1) do
+ (unless (element-equal bs1 bs2 i)
+ (return (if (element-< bs1 bs2 i)
+ :less-than
+ :greater-than)))
+ finally (return :equal))
+ (if (< (buffer-stream-size bs1) (buffer-stream-size bs2))
+ :less-than
+ :greater-than)))
+
+
+(defun element-equal (bs1 bs2 offset)
+ (= (deref-array (buffer-stream-buffer bs1) '(:array :unsigned-byte) offset)
+ (deref-array (buffer-stream-buffer bs2) '(:array :unsigned-byte) offset)))
+
+(defun element-< (bs1 bs2 offset)
+ (< (deref-array (buffer-stream-buffer bs1) '(:array :unsigned-byte) offset)
+ (deref-array (buffer-stream-buffer bs2) '(:array :unsigned-byte) offset)))
+
+;;
+;; BTREE Class and useful accessors
+;;
+
+(defclass btree ()
+ ((pool :accessor btree-buffer-pool :initarg :pool
+ :documentation "Maintain a pool of memory pages")
+ (primary-bfile :accessor btree-primary-file :initarg :bfile
+ :documentation "The file store for btrees")
+ (root :accessor btree-root :initarg :root
+ :documentation "The in-memory root of main BTree DB")
+ (compare-fn :accessor btree-compare-fn :initarg :compare-fn)))
+
+(defmethod btree-stream ((bt btree))
+ (binary-file-stream (btree-file bt)))
+
+(defmethod btree-get-page ((bt btree) position)
+ (get-page (btree-buffer-pool bt) (btree-stream bt) position))
+
+(defmethod btree-allocation-pointer ((bt btree))
+ (read-field +root-alloc-pointer+ (btree-root bt)))
+
+(defmethod write-btree-allocation-pointer (value (bt btree))
+ (write-field +root-alloc-pointer+ (btree-root bt) value))
+
+(defsetf btree-allocation-pointer write-btree-allocation-pointer)
+
+(defmethod btree-free-pointer ((bt btree))
+ (read-field +root-free-pointer+ (btree-root bt)))
+
+(defmethod write-btree-free-pointer (value (bt btree))
+ (write-field +root-alloc-pointer+ (btree-root bt) value))
+
+(defsetf btree-free-pointer write-btree-free-pointer)
+
+;;
+;; Manipulating backing store
;;
+;; Physical operations (not init, no flush)
+
+(defmethod pop-free-db-page ((bt btree))
+ "Take a page off the free list"
+ (let* ((pop-page (btree-get-page bt (btree-free-pointer bt)))
+ (new-top-page (btree-get-page bt (read-field +free-list-next+ pop-page))))
+ (setf (btree-free-pointer bt) (page-position new-top-page))
+ pop-page))
+
+(defmethod push-free-db-page ((bt btree) free-page)
+ "Pushes an initialized (tagged) free page on the free list"
+ (let ((new-top (page-position free-page))
+ (old-top-page (btree-get-page bt (btree-free-pointer bt))))
+ (write-field +free-list-next+ free-page old-top-page)
+ (setf (btree-free-pointer bt) new-top)
+ free-page))
+
+(defmethod new-db-page ((bt btree))
+ "Append a new page to the disk file"
+ (let ((new-page-position (btree-allocation-pointer bt)))
+ (incf (btree-allocation-pointer bt)
+ (page-size (btree-root bt)))
+ new-page-position))
+
+(defmethod get-free-db-page ((bt btree))
+ "Get a fresh page from free list or by allocation"
+ (if (> (btree-free-pointer bt) 0)
+ (pop-free-db-page bt)
+ (new-db-page bt)))
+
+(defmethod leaf-next (page)
+ "Access the next page field of a leaf"
+ (read-field +leaf-next+ page))
+(defmethod set-leaf-next (page pointer)
+ (write-field +leaf-next+ page pointer))
+(defsetf leaf-next set-leaf-next)
+
+(defmethod set-leaf-prev (page pointer)
+ "Access the prev page field of a leaf"
+ (write-field +leaf-prev+ page pointer))
+(defmethod leaf-prev (page)
+ (read-field +leaf-prev+ page))
+(defsetf leaf-prev set-leaf-prev)
+
+;; Logical operations
+
+(defmethod free-page ((bt btree) page)
+ "Free a page so it goes on the free list"
+ (initialize-free-page page)
+ (push-free-db-page bt page))
+
+(defmethod allocate-index-page ((bt btree))
+ (let ((idx-page (get-free-db-page bt)))
+ (initialize-index-page idx-page)
+ idx-page))
+
+(defmethod allocate-leaf-page ((bt btree))
+ (let ((leaf-page (get-free-db-page bt)))
+ (initialize-leaf-page leaf-page)
+ leaf-page))
+
+(defun insert-leaf-page (new-page new-pointer prev-page next-page)
+ "Link in a leaf page from the double linked list of leaf pages"
+ (setf (leaf-prev new-page) (leaf-prev next-page)
+ (leaf-next new-page) (leaf-next prev-page)
+ (leaf-next prev-page) new-pointer
+ (leaf-prev next-page) new-pointer)
+ new-page)
+
+(defun delete-leaf-page (old-page)
+ "Remove a leaf page from the double linked list of leaf pages"
+ (setf (leaf-next (leaf-prev old-page)) (leaf-next old-page)
+ (leaf-prev (leaf-next old-page)) (leaf-prev old-page)))
+
+
;;
-;; Page headers
+;; Manipulating keys and values
;;
-
-(defun read-page-header (page)
- (with-buffer-streams (header)
- (buffer-write-from-array-offset (page-buffer page) 0 1 header)
- (setf (page-type page) (get-type (buffer-read-byte header)))))
-(defun write-page-header (page)
- (with-buffer-streams (header)
- (buffer-write-byte (get-type-id (page-type page)) header)
- (buffer-read-to-array-offset (page-buffer page) 0 header)))
+(defun insert-key (page start key-bs pointer)
+ "Given a point just after a key/pointer or
+ at the beginning of a key region, insert and
+ copy the remaining data to make room checking
+ for boundary conditions"
+ (let* ((last-byte (last-valid-byte page))
+ (region-size (- last-byte start))
+ (length (buffer-stream-size key-bs))
+ (offset (+ length 8)))
+ (assert (< (+ last-byte offset) (page-size page)))
+ (assert (< offset 256))
+ (copy-region page start region-size offset)
+ (write-key page start key-bs pointer)
+ (setf (last-valid-byte page) (+ offset last-byte))
+ page))
+
+(defun insert-key-and-value (page start key-bs pointer value-bs)
+ (let* ((last-byte (last-valid-byte page))
+ (region-size (- last-byte start))
+ (length (+ (buffer-stream-size key-bs)
+ (buffer-stream-size value-bs)))
+ (offset (+ length 12)))
+ (assert (< (+ last-byte offset) (page-size page)))
+ (assert (< offset 256))
+ (copy-region page start region-size offset)
+ (write-key page start key-bs pointer)
+ (write-value page (+ start 8) value-bs)
+ (setf (last-valid-byte page) (+ offset last-byte))
+ page))
+
+(defun delete-key (page start)
+ (let* ((last-byte (last-valid-byte page))
+ (key-size (read-integer page start))
+ (begin (+ start key-size 8))
+ (region-size (- last-byte begin))
+ (offset (- (+ key-size 8))))
+ (copy-region page begin region-size offset)
+ (setf (last-valid-byte page) (+ offset last-byte))
+ page))
+
+(defun delete-key-and-value (page start)
+ (let* ((last-byte (last-valid-byte page))
+ (key-size (read-integer page start))
+ (value-size (read-integer page (+ start key-size 4)))
+ (delete-size (+ key-size value-size 12))
+ (begin (+ start delete-size))
[169 lines skipped]
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/08 15:57:19 1.2
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/12 20:36:44 1.3
@@ -1,3 +1,18 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend
+;;;
+;;; part of
+;;;
+;;; Elephant Object Oriented Database: Common Lisp Backend
+;;;
+;;; Copyright (c) 2007 by Ian Eslick
+;;; <ieslick at common-lisp.net>
+;;;
+;;; Elephant Lisp Backend users are granted the rights to distribute
+;;; and use this software as governed by the terms of the Lisp Lesser
+;;; GNU Public License (http://opensource.franz.com/preamble.html),
+;;; also known as the LLGPL.
(in-package :db-lisp)
@@ -5,14 +20,14 @@
((path :initarg :path :initarg "" :accessor binary-file-path)
(stream :initarg :stream :accessor binary-file-stream)))
-(defun open-binary-file (path &optional (if-does-not-exist :create))
- (let ((stream (open path
- :direction :io :element-type '(unsigned-byte 8)
- :if-exists :overwrite :if-does-not-exist if-does-not-exist)))
- (when stream
- (make-instance 'binary-file :path path :stream stream))))
+(defmethod initialize-instance :after ((file binary-file) &key (if-does-not-exist :create))
+ (assert (binary-file-path file))
+ (setf (binary-file-stream file)
+ (open (binary-file-path file)
+ :direction :io :element-type '(unsigned-byte 8)
+ :if-exists :overwrite :if-does-not-exist if-does-not-exist)))
-(defmethod close-binary-file ((bf binary-file))
+(defmethod close-file ((bf binary-file))
(close (binary-file-stream bf)))
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 23:05:46 1.3
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/12 20:36:44 1.4
@@ -1,5 +1,21 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend
+;;;
+;;; part of
+;;;
+;;; Elephant Object Oriented Database: Common Lisp Backend
+;;;
+;;; Copyright (c) 2007 by Ian Eslick
+;;; <ieslick at common-lisp.net>
+;;;
+;;; Elephant Lisp Backend users are granted the rights to distribute
+;;; and use this software as governed by the terms of the Lisp Lesser
+;;; GNU Public License (http://opensource.franz.com/preamble.html),
+;;; also known as the LLGPL.
+
(in-package :cl-user)
(defpackage :db-lisp
- (:use :cl :elephant :elephant-backend :elephant-memutil))
+ (:use :cl :elephant :elephant-backend :elephant-memutil :uffi))
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 23:05:46 1.2
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/12 20:36:44 1.3
@@ -1,3 +1,19 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend
+;;;
+;;; part of
+;;;
+;;; Elephant Object Oriented Database: Common Lisp Backend
+;;;
+;;; Copyright (c) 2007 by Ian Eslick
+;;; <ieslick at common-lisp.net>
+;;;
+;;; Elephant Lisp Backend users are granted the rights to distribute
+;;; and use this software as governed by the terms of the Lisp Lesser
+;;; GNU Public License (http://opensource.franz.com/preamble.html),
+;;; also known as the LLGPL.
+
(in-package :db-lisp)
;;
@@ -40,7 +56,7 @@
(setf (dlist-next node) after)
(setf (dlist-prev node) before)
(unless (null after)
- (setf (page-prev after) ndoe))
+ (setf (dlist-prev after) node))
node)
(defmethod unlink-node ((node doubly-linked-list-mixin))
@@ -82,7 +98,7 @@
(defmethod write-integer (fixnum page offset &optional (bytes 4))
(declare (type fixnum fixnum offset bytes))
- (write-fixnum-to-array fixnum (page-buffer page) offset bytes))
+ (write-integer-to-array fixnum (page-buffer page) offset bytes))
(defmethod read-integer (page offset &optional (bytes 4))
(declare (type fixnum offset bytes))
@@ -92,10 +108,24 @@
(defmethod copy-page ((page1 buffer-page) (page2 buffer-page))
(copy-slots page1 page2 '(position type size dirty-p stream))
- (loop for (i fixnum) from 0 below (page-size page2) do
+ (loop for i fixnum from 0 below (page-size page2) do
(setf (aref (page-buffer page2) i)
(aref (page-buffer page1) i))))
+(defmethod copy-region ((page buffer-page) start length offset)
+ "Move region defined by start and length offset bytes. If offset
+ is negative, move to lower parts of the array, if position, toward
+ the end."
+ (let ((buffer (page-buffer page)))
+ (declare (type (array (unsigned-byte 8)) buffer))
+ (if (< 0 offset)
+ (loop for i from 0 below length do
+ (setf (aref buffer (+ start offset i))
+ (aref buffer (+ start i))))
+ (loop for i from 0 below length do
+ (setf (aref buffer (- (+ start length offset) i))
+ (aref buffer (- (+ start length) i)))))))
+
;;
;; Read-write buffer-pages from buffer-streams
;;
@@ -115,20 +145,21 @@
;; Page-level IO with backing stream store
;;
-(defmethod associate-page ((page associated-buffer-page) (stream stream) position)
- (setf (page-file-position page) position)
- (setf (page-stream-store page) stream))
+(defmethod associate-page ((page buffer-page) (stream stream) position)
+ (setf (page-position page) position)
+ (setf (page-stream-store page) stream)
+ page)
(defmethod seek-to-page ((page buffer-page))
- (file-position (page-stream page) (page-position page)))
+ (file-position (page-stream-store page) (page-position page)))
(defmethod load-page ((page buffer-page))
(seek-to-page page)
- (read-sequence (page-buffer page) str))
+ (read-sequence (page-buffer page) (page-stream-store page)))
(defmethod flush-page ((page buffer-page))
(seek-to-page page)
- (write-sequence (page-buffer page) str))
+ (write-sequence (page-buffer page) (page-stream-store page)))
(defmethod zero-page ((page buffer-page) &optional (value 0))
(loop for i from 0 upto (1- (length (page-buffer page))) do
@@ -163,7 +194,7 @@
(setf (pool-free-list pool) (make-page)))
(let ((prior (pool-free-list pool)))
(dotimes (i (pool-pages pool) pool)
- (setf prior (link-page (make-page) prior nil))))))
+ (setf prior (link-node (make-page) prior nil))))))
;;
;; Pool level operations
@@ -173,8 +204,8 @@
"Eject the least recently used, unwritten page, from the cache"
(assert (not (null (pool-lru-page pool))))
(let ((lru (pool-lru-page pool)))
- (setf (pool-lru-page pool) (dlist-prev (unlink-page lru)))
- (loop until (or (null lru) (not (dirty-p lru))) do
+ (setf (pool-lru-page pool) (dlist-prev (unlink-node lru)))
+ (loop until (or (null lru) (not (page-dirty-p lru))) do
(setf lru (dlist-prev lru)))
(when (null lru)
(error "No unwritten pages available to eject! Memory exhausted!"))
@@ -194,9 +225,9 @@
(setf (pool-active-list pool) page))
(defun touch-page (page pool)
- (push-active-list (unlink-node page)))
+ (push-active-list (unlink-node page) pool))
-(defmethod get-empty-page ((pool buffer-pool) position)
+(defmethod get-empty-page ((pool buffer-pool))
(if (null (pool-free-list pool))
(eject-page pool)
(pop-free-list pool)))
@@ -214,9 +245,9 @@
;;
;; ------------------------------------------------------------------------
-(defmethod get-page ((pool buffer-pool) stream position)
+(defmethod get-page ((pool buffer-pool) position stream)
(touch-page
- (or (lookup-page pool)
+ (or (lookup-page pool position stream)
(cache-page pool
(load-page
(associate-page (get-empty-page pool) stream position))))
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/ele-lisp.asd 2007/02/12 20:36:45 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/ele-lisp.asd 2007/02/12 20:36:45 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend
;;;
;;; part of
;;;
;;; Elephant Object Oriented Database: Common Lisp Backend
;;;
;;; Copyright (c) 2007 by Ian Eslick
;;; <ieslick at common-lisp.net>
;;;
;;; Elephant and Elephant Lisp Backend users are granted the rights to
;;; distribute and use this software as governed by the terms of the
;;; Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html),
;;; also known as the LLGPL.
(in-package :cl-user)
(defpackage ele-lisp-system
(:use :cl :asdf :elephant-system))
(in-package :ele-lisp-system)
;;
;; System definition
;;
(defsystem ele-lisp
:name "elephant-db-lisp"
:author "Ian Eslick <ieslick at common-lisp.net>"
:version "0.7.0"
:maintainer "Ian Eslick <ieslick at common-lisp.net>"
:licence "LLGPL"
:description "Lisp backend for the Elephant persistent object database"
:components
((:module :src
:components
((:module :contrib
:components
((:module :eslick
:components
((:module :db-lisp
:components
((:file "package")
(:file "file")
(:file "pages")
(:file "log")
(:file "btree")
(:file "transactions")
(:file "btree-ops")
(:file "lisp-transactions")
(:file "lisp-slots")
(:file "lisp-collections")
(:file "lisp-controller"))
:serial t))))))))
:depends-on (:elephant))
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/log.lisp 2007/02/12 20:36:45 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/log.lisp 2007/02/12 20:36:45 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend
;;;
;;; part of
;;;
;;; Elephant Object Oriented Database: Common Lisp Backend
;;;
;;; Copyright (c) 2007 by Ian Eslick
;;; <ieslick at common-lisp.net>
;;;
;;; Elephant Lisp Backend users are granted the rights to distribute
;;; and use this software as governed by the terms of the Lisp Lesser
;;; GNU Public License (http://opensource.franz.com/preamble.html),
;;; also known as the LLGPL.
(in-package :db-lisp)
;;
;; Simple logging facility to track operations
;;
(defparameter *default-log-page-size*)
(defclass binary-file-logger ()
((lock :accessor bflogger-lock :initarg :lock :initform (make-ele-lock))
(filename :accessor bflogger-filename :initarg :filename)
(binary-file :accessor bflogger-bfile :initform nil)
(current-offset :accessor bflogger-offset :initarg :offset :initform 0)
(operation-reader :accessor bflogger-ops :initarg :op-reader)))
(defmethod initialize-instance :after ((log binary-file-logger) &rest rest)
(unless (bflogger-stream log)
(setf (bflogger-bfile log)
(open-binary-file (bflogger-filename log)))))
(defmethod bflogger-stream ((log binary-file-logger))
(when (bflogger-bfile log)
(binary-file-stream (bflogger-bfile log))))
;;
;; Error conditions on log operations
;;
(define-condition log-full ()
((filename :accessor log-full-filename :initarg :filename)
(logger :accessor log-full-logger :logger)))
(define-condition operation-error (error)
((op :accessor operation-error-op :initarg :op)))
;;
;; Top-level user interface
;;
(defun open-log (path &key (max-bytes (expt 2 23)))
(make-instance 'binary-file-logger :filename path))
(defmethod close-log ((log binary-file-logger))
(when (bflogger-bfile log)
(close-binary-file (bflogger-bfile log))))
;;
;; Record and play operations
;;
(defclass bflog-op ()
((operation-id :accessor bflog-op-id :initarg :op-id :initform nil)
(file-offset :accessor bflog-op-offset :initarg :offset :initform nil)
(payload :accessor bflog-op-payload :initarg :payload))
(:documentation "A cooperative class for reading and writing data to logs
as well as replaying logged operations. Intended as a
base class for users"))
(defclass end-of-log-op (bflog-op)
((operation-id :initform +eol-op+)))
;;
;; Payload API
;;
(defmethod unparse-payload ((op bflog-op) array offset)
"Default method; assume payload is a byte-array and return it, otherwise
base class should override and return an array"
(bflog-op-payload op))
(defmethod unparse-payload :around ((op bflog-op) array )
(let ((payload (call-next-method)))
(assert (typep payload '(array (unsigned-byte 8))))
payload))
(defmethod parse-payload ((op bflog-op) (array (array (unsigned-byte 8))) offset)
(declare (type fixnum offset))
(setf (bflog-op-payload op) array))
;;
;; User interface
;;
(defvar *log-temp-array* (make-array 10000 :element-type '(unsigned-byte 8) :fill-pointer t :adjustable t))
(defmethod write-operation ((op bflog-op) (log binary-file-logger))
(let ((array *log-temp-array*))
(with-ele-lock (bflogger-lock log)
(write-integer-to-array (bflog-op-id op) array 0 1) ;; tag
(parse-payload op array 4) ;; get payload starting after length field
(let ((end (fill-pointer array))) ;; length of payload
(write-integer-to-array (- end 5) 1 4) ;; write payload length
(write-sequence array (bflogger-stream log) :end (fill-pointer array)) ;; dump to disk
(setf (fill-pointer array) 0))
(finish-output (bflogger-stream log))
t)))
;;(defmethod read-operation ((log binary-file-logger))
;; (read-sequence
More information about the Elephant-cvs
mailing list