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@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@common-lisp.net" :version "0.7.0" :maintainer "Ian Eslick ieslick@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