├── Test ├── utilities.lisp ├── test.lisp ├── packages.lisp ├── clobber-test.asd └── test-serialize.lisp ├── Base ├── conditions.lisp ├── clobber-base.asd ├── packages.lisp ├── docstrings.lisp ├── methods.lisp ├── serialize-methods.lisp ├── utilities.lisp └── protocol.lisp ├── clobber.asd ├── .gitignore ├── LICENSE.text ├── Documentation └── demo │ ├── demo1.lisp │ ├── common.lisp │ ├── demo2.lisp │ └── demo3.lisp └── README.org /Test/utilities.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-test) 2 | 3 | -------------------------------------------------------------------------------- /Test/test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-test) 2 | 3 | (defun run-tests () 4 | (test-serialize)) 5 | -------------------------------------------------------------------------------- /Base/conditions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-internal) 2 | 3 | (define-condition clobber-error (error) 4 | ()) 5 | -------------------------------------------------------------------------------- /Test/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:clobber-test 4 | (:use #:common-lisp #:clobber #:clobber-internal) 5 | (:export #:run-tests)) 6 | -------------------------------------------------------------------------------- /Base/clobber-base.asd: -------------------------------------------------------------------------------- 1 | (defsystem #:clobber-base 2 | :depends-on (#:closer-mop) 3 | :serial t 4 | :components 5 | ((:file "packages") 6 | (:file "conditions") 7 | (:file "protocol") 8 | (:file "utilities") 9 | (:file "methods") 10 | (:file "serialize-methods") 11 | (:file "docstrings"))) 12 | 13 | -------------------------------------------------------------------------------- /Test/clobber-test.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem #:clobber-test 4 | :depends-on (#:clobber) 5 | :serial t 6 | :components 7 | ((:file "packages") 8 | (:file "utilities") 9 | (:file "test-serialize") 10 | (:file "test")) 11 | :perform (test-op (operation component) 12 | (uiop:symbol-call '#:clobber-test '#:run-tests))) 13 | -------------------------------------------------------------------------------- /clobber.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :clobber 4 | :description "Library for transaction-oriented data bases." 5 | :author "Robert Strandh " 6 | :license "FreeBSD, see file LICENSE.text" 7 | :depends-on (#:clobber-base) 8 | :serial t 9 | :components 10 | ((:module "Documentation/demo" 11 | :components ((:file "common") 12 | (:file "demo1") 13 | (:file "demo2") 14 | (:file "demo3")))) 15 | :in-order-to ((test-op (test-op "clobber-test")))) 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .gateway.* 2 | 3 | # lisp 4 | *.FASL 5 | *.fasl 6 | *.lisp-temp 7 | *.lx64fsl 8 | 9 | .__* 10 | 11 | # emacs 12 | *~ 13 | \#*\# 14 | /.emacs.desktop 15 | /.emacs.desktop.lock 16 | *.elc 17 | auto-save-list 18 | tramp 19 | .\#* 20 | 21 | # Org-mode 22 | .org-id-locations 23 | *_archive 24 | 25 | # flymake-mode 26 | *_flymake.* 27 | 28 | # eshell files 29 | /eshell/history 30 | /eshell/lastdir 31 | 32 | # elpa packages 33 | /elpa/ 34 | 35 | # reftex files 36 | *.rel 37 | 38 | # AUCTeX auto folder 39 | /auto/ 40 | 41 | # cask packages 42 | .cask/ 43 | dist/ 44 | 45 | # Flycheck 46 | flycheck_*.el 47 | 48 | # server auth directory 49 | /server/ 50 | 51 | # projectiles files 52 | .projectile 53 | -------------------------------------------------------------------------------- /Base/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:common-lisp-user) 2 | 3 | (defpackage #:clobber 4 | (:use) 5 | (:export 6 | ;; conditions 7 | #:clobber-error 8 | #:transaction-log-not-open 9 | 10 | #:define-save-info 11 | #:open-transaction-log 12 | #:close-transaction-log 13 | #:transaction-log-open-p 14 | #:log-transaction 15 | #:with-transaction-log 16 | #:commit 17 | #:clear-uncommitted 18 | ;; utilities 19 | #:with-string-transaction-log 20 | #:serialize-to-string 21 | #:hash-table-to-alist 22 | #:make-a-hash-table)) 23 | 24 | (defpackage #:clobber-internal 25 | (:use #:common-lisp #:clobber) 26 | (:export 27 | #:load-transaction-log 28 | #:make-transaction-log 29 | #:serialize)) 30 | -------------------------------------------------------------------------------- /Base/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-internal) 2 | 3 | (setf 4 | (documentation #'open-transaction-log 'function) 5 | "Load transaction log from FILENAME and return an instance of `clobber:transaction-log'. 6 | 7 | FUNCTION should accept a single argument, a transaction object (see 8 | `clobber:load-transaction-log').") 9 | 10 | (setf 11 | (documentation #'load-transaction-log 'function) 12 | "Read transaction log from FILENAME, calling FUNCTION for each transaction. 13 | 14 | FUNCTION should accept a single argument, a transaction object. 15 | 16 | OBJECT-TABLE should be a hash table.") 17 | 18 | (setf 19 | (documentation 'define-save-info 'function) 20 | "Define SAVE-INFO as data to serialize for instances of TYPE. 21 | 22 | Each form in SAVE-INFO should be a list of two elements - 23 | 24 | (INITARG ACCESSOR) 25 | 26 | where INITARG and ACCESSOR should correspond to a slot for TYPE.") 27 | 28 | (setf 29 | (documentation 'with-transaction-log 'function) 30 | "Load transaction log from PATH using FUNCTION, execute FORMS, and close the log. 31 | 32 | VAR is bound to an instance of `transaction-log'.") 33 | -------------------------------------------------------------------------------- /LICENSE.text: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2015 - 2016 2 | ;;;; 3 | ;;;; Robert Strandh (robert.strandh@gmail.com) 4 | ;;;; 5 | ;;;; All rights reserved. 6 | ;;;; 7 | ;;;; Redistribution and use in source and binary forms, with or 8 | ;;;; without modification, are permitted provided that the following 9 | ;;;; conditions are met: 10 | ;;;; 11 | ;;;; 1. Redistributions of source code must retain the above copyright 12 | ;;;; notice, this list of conditions and the following disclaimer. 13 | ;;;; 2. Redistributions in binary form must reproduce the above 14 | ;;;; copyright notice, this list of conditions and the following 15 | ;;;; disclaimer in the documentation and/or other materials 16 | ;;;; provided with the distribution. 17 | ;;;; 18 | ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 19 | ;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 20 | ;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 21 | ;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | ;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 23 | ;;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 24 | ;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 25 | ;;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | ;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 27 | ;;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | ;;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 29 | ;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | ;;;; POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Test/test-serialize.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-test) 2 | 3 | (defun test-serialize-cons () 4 | (format *trace-output* "~&; serialize test~%") 5 | (assert (string= 6 | (serialize-to-string (cons 'a 'b)) 7 | "#2!(CLOBBER-TEST::A . CLOBBER-TEST::B)"))) 8 | 9 | (defun test-serialize-generic-functions () 10 | (defclass c1 () 11 | ((%s1 :initform 1 :accessor a1))) 12 | (assert (string= 13 | (serialize-to-string #'(setf a1)) 14 | "#2!(COMMON-LISP:SETF . #3!(CLOBBER-TEST::A1 . COMMON-LISP:NIL))"))) 15 | 16 | (defun test-serialize-hash-tables () 17 | (let ((ht (make-hash-table :test #'equal)) 18 | serialization-string 19 | reconstructed-ht) 20 | (setf (gethash 'key1 ht) :val1) 21 | (setf (gethash 'key2 ht) :val2) 22 | (setf serialization-string (serialize-to-string ht)) 23 | #+(or)(print serialization-string) 24 | (with-input-from-string (in serialization-string) 25 | (with-transaction-log (log (cons in *standard-output*) 26 | (lambda (just-read-transaction) 27 | #+(or)(print just-read-transaction) 28 | (setf reconstructed-ht 29 | just-read-transaction))) 30 | (assert (hash-table-p reconstructed-ht)) 31 | (assert (eql (hash-table-test reconstructed-ht) 32 | (hash-table-test ht))) 33 | (assert (eql (hash-table-size reconstructed-ht) 34 | (hash-table-size ht))) 35 | (assert (eql (hash-table-rehash-size reconstructed-ht) 36 | (hash-table-rehash-size ht))) 37 | (assert (eql (hash-table-rehash-threshold reconstructed-ht) 38 | (hash-table-rehash-threshold ht))) 39 | (maphash (lambda (key ht-val 40 | &aux (reconstructed-ht-val (gethash key reconstructed-ht))) 41 | (assert (eql reconstructed-ht-val ht-val))) 42 | ht))))) 43 | 44 | (defun test-serialize () 45 | (test-serialize-cons) 46 | (test-serialize-generic-functions) 47 | (test-serialize-hash-tables)) 48 | -------------------------------------------------------------------------------- /Base/methods.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-internal) 2 | 3 | (defmethod open-transaction-log ((streams-pair cons) function) 4 | (let ((object-table (make-hash-table)) 5 | (input-stream (car streams-pair)) 6 | (output-stream (cdr streams-pair))) 7 | (unless (null input-stream) ; read the transaction log from the input stream 8 | (load-transaction-log input-stream function object-table)) 9 | (make-transaction-log output-stream object-table))) 10 | 11 | (defmethod open-transaction-log ((filename pathname) function) 12 | (let ((object-table (make-hash-table))) 13 | (load-transaction-log filename function object-table) 14 | (make-transaction-log filename object-table))) 15 | 16 | ;;; Internal protocol 17 | 18 | (defmethod load-transaction-log ((input-stream stream) function object-table) 19 | (let ((*readtable* (copy-readtable))) 20 | (set-syntax *readtable* object-table) 21 | (loop for transaction = (read input-stream nil nil) 22 | until (null transaction) 23 | do (funcall function transaction)))) 24 | 25 | (defmethod load-transaction-log ((input string) function object-table) 26 | (with-input-from-string (input-stream input) 27 | (load-transaction-log input-stream function object-table))) 28 | 29 | (defmethod load-transaction-log ((filename pathname) function object-table) 30 | (with-open-file (input-stream filename 31 | :direction :input 32 | :if-does-not-exist :create) 33 | (load-transaction-log input-stream function object-table))) 34 | 35 | (defmethod make-transaction-log ((output-stream stream) object-table) 36 | (multiple-value-bind (object-id-table max-object-id) 37 | (make-object-id-table object-table) 38 | (make-instance 'transaction-log 39 | :final-log-stream output-stream 40 | :object-id-table object-id-table 41 | :next-object-id (1+ max-object-id)))) 42 | 43 | (defmethod make-transaction-log ((output pathname) object-table) 44 | (let ((output-stream (open output 45 | :direction :output 46 | :if-exists :append))) 47 | (make-transaction-log output-stream object-table))) 48 | -------------------------------------------------------------------------------- /Documentation/demo/demo1.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:clobber-demo/demo1 2 | (:use #:common-lisp #:clobber-demo/common) 3 | (:export #:do-things)) 4 | 5 | (in-package #:clobber-demo/demo1) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;;; 9 | ;;; Transaction logging by Clobber 10 | 11 | (defun execute (transaction-function &rest arguments) 12 | (clobber:clear-uncommitted *transaction-log*) 13 | (clobber:log-transaction (cons transaction-function arguments) 14 | *transaction-log*) 15 | (apply transaction-function arguments) 16 | (clobber:commit *transaction-log*)) 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;;; 20 | ;;; Starting and stopping 21 | 22 | (defun start (filename) 23 | (setf *banks* '()) 24 | (setf *transaction-log* 25 | (clobber:open-transaction-log 26 | filename 27 | (lambda (transaction) 28 | (apply (car transaction) (cdr transaction)))))) 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;; 32 | ;;; The actual application 33 | 34 | (defun do-things () 35 | (let ((b1 (make-instance 'bank)) 36 | (b2 (make-instance 'bank)) 37 | (jane (make-instance 'person :name "Jane")) 38 | (bill (make-instance 'person :name "Bill"))) 39 | (execute 'new-bank b1) 40 | (execute 'new-bank b2) 41 | (execute 'add-customer jane b1) 42 | (execute 'add-customer jane b2) 43 | (execute 'add-customer bill b1) 44 | (handler-case 45 | (execute 'add-customer typo1 typo2) ; error happens so it will not be committed 46 | (error ())) 47 | (let ((a1 (make-instance 'account :holder jane)) 48 | (a2 (make-instance 'account :holder jane)) 49 | (a3 (make-instance 'account :holder bill))) 50 | (execute 'add-account a1 b1) 51 | (execute 'add-account a2 b2) 52 | (execute 'add-account a3 b1) 53 | (execute 'deposit 100 a1) 54 | (execute 'deposit 200 a2) 55 | (execute 'deposit 300 a3) 56 | (execute 'withdraw 10 a3) 57 | (execute 'transfer 20 a2 a1)))) 58 | 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | ;;; 61 | ;;; Demonstrating the application 62 | ;;; 63 | ;;; (delete-database) ; clean up 64 | ;;; (do-and-see) ; see what the database file contains after the execution of transactions 65 | ;;; (reload-database) ; see that *banks* has the data freshly revived from the database file. 66 | 67 | 68 | (defvar *database-file* (merge-pathnames "demo1-database" (user-homedir-pathname))) 69 | 70 | (defun do-and-see () 71 | (start *database-file*) 72 | (do-things) 73 | ;;; inspect the file to see the transaction log 74 | (with-open-file (stream *database-file*) 75 | (let ((data (make-string (file-length stream)))) 76 | (read-sequence data stream) 77 | data))) 78 | 79 | (defun reload-database () 80 | (stop) 81 | (start *database-file*)) 82 | 83 | (defun reload-database-and-see () 84 | (reload-database) 85 | *banks*) 86 | 87 | (defun delete-database () 88 | (stop) 89 | (when (probe-file *database-file*) 90 | (delete-file *database-file*))) 91 | 92 | -------------------------------------------------------------------------------- /Documentation/demo/common.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:clobber-demo/common 2 | (:use #:common-lisp) 3 | (:export 4 | #:bank 5 | #:accounts 6 | #:customers 7 | 8 | #:account 9 | #:balance 10 | #:holder 11 | 12 | #:person 13 | #:name 14 | 15 | #:*banks* 16 | #:new-bank 17 | #:delete-bank 18 | #:add-customer 19 | #:add-account 20 | #:withdraw 21 | #:deposit 22 | #:transfer 23 | 24 | #:*transaction-log* 25 | #:stop)) 26 | 27 | (in-package #:clobber-demo/common) 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;;; 31 | ;;; The model. 32 | 33 | (defclass bank () 34 | ((%accounts :initform '() :accessor accounts) 35 | (%customers :initform '() :accessor customers))) 36 | 37 | (defclass account () 38 | ((%bank :initarg :bank :accessor bank) 39 | (%balance :initform 0 :accessor balance) 40 | (%holder :initarg :holder :reader holder))) 41 | 42 | (clobber:define-save-info account 43 | (:holder holder)) 44 | 45 | (defclass person () 46 | ((%name :initarg :name :reader name))) 47 | 48 | (defun id (object) 49 | (mod (sxhash object) 100)) 50 | 51 | (defmethod print-object ((bank bank) stream) 52 | (prin1 `(:bank-id ,(id bank) 53 | :accounts ,(accounts bank) 54 | :customers ,(customers bank)) 55 | stream)) 56 | 57 | (defmethod print-object ((account account) stream) 58 | (prin1 `(:account-id ,(id account) 59 | :parent-bank-id ,(id (bank account)) 60 | :balance ,(balance account) 61 | :holder ,(holder account)) 62 | stream)) 63 | 64 | (defmethod print-object ((person person) stream) 65 | (format stream "<~A>" (name person))) 66 | 67 | (clobber:define-save-info person 68 | (:name name)) 69 | 70 | (defparameter *banks* '()) 71 | 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | ;;; 74 | ;;; Transactions. 75 | 76 | (defun new-bank (bank) 77 | (push bank *banks*)) 78 | 79 | (defun delete-bank (bank) 80 | (setf *banks* (remove bank *banks*))) 81 | 82 | (defun add-customer (person bank) 83 | (push person (customers bank))) 84 | 85 | (defun add-account (account bank) 86 | (push account (accounts bank)) 87 | (setf (bank account) bank)) 88 | 89 | (defun withdraw (amount account) 90 | (decf (balance account) amount)) 91 | 92 | (defun deposit (amount account) 93 | (incf (balance account) amount)) 94 | 95 | (defun transfer (amount from-account to-account) 96 | (withdraw amount from-account) 97 | (deposit amount to-account)) 98 | 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | ;;; 101 | ;;; Transaction logging by Clobber 102 | 103 | (defparameter *transaction-log* nil) 104 | 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | ;;; 107 | ;;; Starting and stopping 108 | 109 | (defun stop () 110 | (when (clobber:transaction-log-open-p *transaction-log*) 111 | (clobber:close-transaction-log *transaction-log*))) 112 | 113 | -------------------------------------------------------------------------------- /Base/serialize-methods.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-internal) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Serialization of objects other than instances of STANDARD-OBJECT. 6 | 7 | ;;; A number is serialized as it is normally printed. 8 | 9 | (defmethod serialize ((object number) transaction-log) 10 | (prin1 object (log-stream transaction-log))) 11 | 12 | ;;; A character is serialized as it is normally printed. 13 | 14 | (defmethod serialize ((object character) transaction-log) 15 | (prin1 object (log-stream transaction-log))) 16 | 17 | ;;; A symbol is serialized by printing it with its package prefix. We 18 | ;;; accomplish this by setting *package* to the keyword package while 19 | ;;; printing the symbol. 20 | 21 | (defmethod serialize ((object symbol) transaction-log) 22 | (let ((*package* (find-package '#:keyword))) 23 | (prin1 object (log-stream transaction-log)))) 24 | 25 | (defmethod serialize ((object standard-generic-function) transaction-log) 26 | (let ((name (closer-mop:generic-function-name object))) 27 | (serialize name transaction-log))) 28 | 29 | (def-serialize-method ((object cons) transaction-log) (id% log-stream) 30 | (format log-stream "#~d!(" id%) 31 | (serialize (car object) transaction-log) 32 | (format log-stream " . ") 33 | (serialize (cdr object) transaction-log) 34 | (format log-stream ")")) 35 | 36 | ;;; FIXME: add serialization of arbitrary arrays. 37 | 38 | (def-serialize-method ((object vector) transaction-log) (id log-stream) 39 | (format log-stream "#~d!#(" id) 40 | (loop for element across object 41 | do (serialize element transaction-log) 42 | (format log-stream " ")) 43 | (format log-stream ")")) 44 | 45 | (def-serialize-method ((object string) transaction-log) (id log-stream) 46 | (format log-stream "#~d!\"" id) 47 | (loop for char across object 48 | do (cond ((eql char #\") 49 | (format log-stream "\\\"")) 50 | ((eql char #\\) 51 | (format log-stream "\\\\")) 52 | (t 53 | (princ char log-stream)))) 54 | (format log-stream "\"")) 55 | 56 | (defun serialize-pair (initarg value transaction-log 57 | &aux (log-stream (log-stream transaction-log))) 58 | (format log-stream " ") 59 | (serialize initarg transaction-log) 60 | (format log-stream " ") 61 | (serialize value transaction-log)) 62 | 63 | (def-serialize-method ((object standard-object) transaction-log) (id log-stream) 64 | (format log-stream "#~d![" id) 65 | (serialize (class-name (class-of object)) transaction-log) 66 | (loop for info in (save-info object) 67 | do (handler-case 68 | (let* ((initarg (car info)) 69 | (reader (cadr info)) 70 | (value (funcall reader object))) 71 | (serialize-pair initarg value transaction-log)) 72 | (unbound-slot ()))) 73 | (format log-stream "]")) 74 | 75 | (defun hash-table-to-alist (hash-table) 76 | (let ((result '())) 77 | (maphash (lambda (key val) 78 | (push (cons key val) result)) 79 | hash-table) 80 | (nreverse result))) 81 | 82 | (def-serialize-method ((object hash-table) transaction-log) (id log-stream) 83 | (format log-stream "#~d![" id) 84 | (serialize 'hash-table transaction-log) 85 | (serialize-pair :test (hash-table-test object) transaction-log) 86 | (serialize-pair :elements (hash-table-to-alist object) transaction-log) 87 | (serialize-pair :size (hash-table-size object) transaction-log) 88 | (serialize-pair :rehash-size (hash-table-rehash-size object) transaction-log) 89 | (serialize-pair :rehash-threshold (hash-table-rehash-threshold object) transaction-log) 90 | (format log-stream "]")) 91 | 92 | (def-serialize-method ((object pathname) transaction-log) (id log-stream) 93 | (format log-stream "#~d!" id) 94 | (prin1 object log-stream)) 95 | 96 | 97 | -------------------------------------------------------------------------------- /Base/utilities.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-internal) 2 | 3 | ;;; This function returns two values: the object identity table which 4 | ;;; is required for creating the transaction log object and the 5 | ;;; maximum object ID present in the table. Integers above this 6 | ;;; number are free for assignment in subsequent transactions. 7 | 8 | (defun make-object-id-table (object-table) 9 | (let* ((object-id-table (make-hash-table :test #'eq)) 10 | (max-object-id 0) 11 | (fn (lambda (object-id object) 12 | (setf (gethash object object-id-table) object-id 13 | max-object-id (max max-object-id object-id))))) 14 | (maphash fn object-table) 15 | (values object-id-table max-object-id))) 16 | 17 | ;;; There's a pattern of getting an ID for an object, and either printing 18 | ;;; a cycle marker if the ID was seen before (i.e. the object was printed before) 19 | ;;; or printing the object. 20 | ;;; Only the latter is different in each use of the pattern. 21 | 22 | (defun serialize-common (object transaction-log fn) 23 | (with-accessors ((object-id-table object-id-table) 24 | (next-object-id next-object-id) 25 | (log-stream log-stream)) 26 | transaction-log 27 | (let ((id (gethash object object-id-table))) 28 | (if (null id) 29 | (progn 30 | (setf id (incf next-object-id)) 31 | (setf (gethash object object-id-table) id) 32 | (funcall fn object id log-stream transaction-log)) 33 | (format log-stream "#~d^" id))))) 34 | 35 | (defmacro with-serialize-common ((object transaction-log id log-stream) &body body) 36 | `(serialize-common ,object transaction-log 37 | (lambda (,object ,id ,log-stream ,transaction-log) 38 | (declare (ignorable ,id ,log-stream ,transaction-log)) 39 | ,@body))) 40 | 41 | (defmacro def-serialize-method (((object class) transaction-log) (id log-stream) &body body) 42 | `(defmethod serialize ((,object ,class) ,transaction-log) 43 | (with-serialize-common (,object ,transaction-log ,id ,log-stream) 44 | ,@body))) 45 | 46 | (defmacro with-string-transaction-log (symbol &body body) 47 | (let ((output-stream (gensym "OUTPUT-STREAM"))) 48 | `(with-output-to-string (,output-stream) 49 | (let ((,symbol (make-transaction-log ,output-stream (make-hash-table)))) 50 | ,@body)))) 51 | 52 | (defun serialize-to-string (object) 53 | (with-string-transaction-log transaction-log 54 | (serialize object transaction-log) 55 | (commit transaction-log))) 56 | 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | ;;; 59 | ;;; Syntax-setting functions for the transaction log loader. 60 | ;;; 61 | ;;; The readtable used to read a transaction contains three additional 62 | ;;; reader macros, associated with #!, #^ and [. 63 | 64 | (defun set-syntax (readtable object-table) 65 | (let ((*readtable* readtable)) 66 | (%set-syntax-left-bracket ) 67 | (%set-syntax-right-bracket) 68 | (%set-syntax-hash-bang object-table) 69 | (%set-syntax-hash-caret object-table))) 70 | 71 | (defun make-a-hash-table (&key (test #'eql) elements 72 | size rehash-size rehash-threshold) 73 | (let ((hash-table (apply #'make-hash-table 74 | :test test 75 | (append 76 | (unless (null size) 77 | (list :size size)) 78 | (unless (null rehash-size) 79 | (list :rehash-size rehash-size)) 80 | (unless (null rehash-threshold) 81 | (list :rehash-threshold rehash-threshold)))))) 82 | (loop :for (key . value) :in elements 83 | :do (setf (gethash key hash-table) value)) 84 | hash-table)) 85 | 86 | ;;; specification==(object-type :initarg1 initval1 :initarg2 initval2 ...) 87 | (defun fn-and-args (specification) 88 | (case (car specification) 89 | ('hash-table (values #'make-a-hash-table (cdr specification))) 90 | (otherwise (values #'make-instance specification)))) 91 | 92 | (defun %set-syntax-left-bracket () 93 | (set-macro-character 94 | #\[ 95 | (lambda (stream char) 96 | (declare (ignore char)) 97 | (multiple-value-bind (fn args) (fn-and-args (read-delimited-list #\] stream t)) 98 | (apply fn args))))) 99 | 100 | (defun %set-syntax-right-bracket () 101 | (set-syntax-from-char #\] #\))) 102 | 103 | (defun %set-syntax-hash-bang (object-table) 104 | (set-dispatch-macro-character 105 | #\# #\! 106 | (lambda (stream char param) 107 | (declare (ignore char)) 108 | (setf (gethash param object-table) 109 | (read stream nil nil t))))) 110 | 111 | (defun %set-syntax-hash-caret (object-table) 112 | (set-dispatch-macro-character 113 | #\# #\^ 114 | (lambda (stream char param) 115 | (declare (ignore stream char)) 116 | (gethash param object-table)))) 117 | -------------------------------------------------------------------------------- /Documentation/demo/demo2.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:clobber-demo/demo2 2 | (:use #:common-lisp #:clobber-demo/common) 3 | (:export #:do-things 4 | #:*operator* 5 | #:*comment* 6 | #:with-comment 7 | #:transaction 8 | #:function-name 9 | #:arguments 10 | #:creator 11 | #:comment 12 | #:*transactions* 13 | #:log-to-list 14 | #:commit-to-list 15 | #:clear-uncommitted-to-list)) 16 | 17 | (in-package #:clobber-demo/demo2) 18 | 19 | ;;; In this demo we keep a "transaction log" which is a 1-to-1 mapping 20 | ;;; of the Clobber transaction log, but which can be used to query the 21 | ;;; system for information such as "who closed that account?" "when 22 | ;;; was it done?", etc. 23 | 24 | ;;; The person operating the system. 25 | (defparameter *operator* "Suzy") 26 | 27 | ;;; The comment to store in the current transaction. 28 | (defparameter *comment* "") 29 | 30 | ;;; Wrap the execution of a a transaction in this macro 31 | ;;; if a comment is desired. 32 | (defmacro with-comment (comment &body body) 33 | `(let ((*comment* ,comment)) 34 | ,@body)) 35 | 36 | (defclass transaction () 37 | ((%function-name :initarg :function-name :reader function-name) 38 | (%arguments :initarg :arguments :reader arguments) 39 | (%creator :initform *operator* :initarg :creator :reader creator) 40 | (%creation-date :initform (get-universal-time) 41 | :initarg :creation-date 42 | :reader creation-date) 43 | (%comment :initform *comment* :initarg :comment :reader comment))) 44 | 45 | (clobber:define-save-info transaction 46 | (:function-name function-name) 47 | (:arguments arguments) 48 | (:creator creator) 49 | (:creation-date creation-date) 50 | (:comment comment)) 51 | 52 | (defmethod print-object ((tr transaction) stream) 53 | (progn ;;print-unreadable-object (tr stream :type nil :identity nil) 54 | (with-accessors ((function-name function-name) 55 | (arguments arguments)) tr 56 | (format stream "#T(~A ~{~A~^ ~})" function-name arguments)))) 57 | 58 | ;;; The transaction log mirrored as a list 59 | (defparameter *transactions* '()) 60 | (defparameter *tmp-transactions* '()) 61 | 62 | (defun log-to-list (transaction) 63 | (push transaction *tmp-transactions*)) 64 | 65 | (defun commit-to-list () 66 | (setf *transactions* (append *tmp-transactions* *transactions*)) 67 | (setf *tmp-transactions* '())) 68 | 69 | (defun clear-uncommitted-to-list () 70 | (setf *tmp-transactions* '())) 71 | 72 | (defun execute (transaction-function &rest arguments) 73 | ;; if an error happened during a previous execution 74 | ;; of some transaction, 75 | ;; remove what was logged temporarily but not committed 76 | (clobber:clear-uncommitted *transaction-log*) 77 | (clear-uncommitted-to-list) 78 | 79 | (let ((transaction (make-instance 'transaction 80 | :function-name transaction-function 81 | :arguments arguments))) 82 | ;; log the transaction to a temporary buffer 83 | ;; before executing it, because the execution 84 | ;; may change the objects from the transaction 85 | ;; which is to be logged 86 | ;; (we want to log the arguments for the function 87 | ;; as they were before executing the function) 88 | (clobber:log-transaction transaction 89 | *transaction-log*) 90 | ;; also log to a temporary list that will be committed 91 | ;; to our list that mirrors the log file 92 | (log-to-list transaction) 93 | ;; now execute the transaction 94 | (apply transaction-function arguments) 95 | ;; if the execution was successful, 96 | ;; commit the temporary buffer to the file 97 | (clobber:commit *transaction-log*) 98 | ;; also commit to our list that mirrors the log file 99 | (commit-to-list))) 100 | 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | ;;; 103 | ;;; Starting and stopping. 104 | 105 | (defun start (filename) 106 | (setf *banks* '()) 107 | (setf *transactions* '()) 108 | (setf *transaction-log* 109 | (clobber:open-transaction-log 110 | filename 111 | (lambda (transaction) 112 | (apply (function-name transaction) 113 | (arguments transaction)) 114 | (push transaction *transactions*))))) 115 | 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | ;;; 118 | ;;; The actual application 119 | 120 | (defun do-things () 121 | (let ((b1 (make-instance 'bank)) 122 | (b2 (make-instance 'bank)) 123 | (jane (make-instance 'person :name "Jane")) 124 | (bill (make-instance 'person :name "Bill"))) 125 | (execute 'new-bank b1) 126 | (execute 'new-bank b2) 127 | (execute 'add-customer jane b1) 128 | (with-comment "What does bank 2 have that bank 1 does not?" 129 | (execute 'add-customer jane b2)) 130 | (execute 'add-customer bill b1) 131 | (let ((a1 (make-instance 'account :holder jane)) 132 | (a2 (make-instance 'account :holder jane)) 133 | (a3 (make-instance 'account :holder bill))) 134 | (execute 'add-account a1 b1) 135 | (execute 'add-account a2 b2) 136 | (execute 'add-account a3 b1) 137 | (with-comment "Gee, I wish they would deposit more money!" 138 | (execute 'deposit 100 a1)) 139 | (execute 'deposit 200 a2) 140 | (execute 'deposit 300 a3) 141 | (execute 'withdraw 10 a3) 142 | (execute 'transfer 20 a2 a1)))) 143 | 144 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 145 | ;;; 146 | ;;; Demonstrating the application 147 | ;;; 148 | ;;; (delete-database) ; clean up 149 | ;;; (do-and-see) ; see what the database file contains after the execution of transactions 150 | ;;; (reload-database) ; see that *banks* has the data freshly revived from the database file. 151 | 152 | 153 | (defvar *database-file* (merge-pathnames "demo2-database" (user-homedir-pathname))) 154 | 155 | (defun do-and-see () 156 | (start *database-file*) 157 | (do-things) 158 | ;;; inspect the file to see the transaction log 159 | (with-open-file (stream *database-file*) 160 | (let ((data (make-string (file-length stream)))) 161 | (read-sequence data stream) 162 | data))) 163 | 164 | (defun reload-database () 165 | (stop) 166 | (start *database-file*)) 167 | 168 | (defun reload-database-and-see () 169 | (reload-database) 170 | *banks*) 171 | 172 | (defun delete-database () 173 | (stop) 174 | (when (probe-file *database-file*) 175 | (delete-file *database-file*))) 176 | -------------------------------------------------------------------------------- /Base/protocol.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:clobber-internal) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Transaction log. 6 | ;;; 7 | ;;; Transactions can be any object. They are logged to the stream by 8 | ;;; using the serialization defined below. Typically, an application 9 | ;;; would either use a list ( ... ) or an 10 | ;;; instance of STANDARD-OBJECT as a transaction. The application 11 | ;;; itself is responsible for what to do with a transaction when a 12 | ;;; transaction log is opened. 13 | 14 | (defclass transaction-log () 15 | (;; A stream to which transactions are logged. 16 | (%log-streami :initarg :final-log-stream :reader final-log-stream) 17 | ;; Sometimes after a transaction is logged (it has to be logged 18 | ;; before it is executed because it may change the objects 19 | ;; the transaction is meant to work with, and the objects 20 | ;; are also logged), the programmer discovers that it had a typo. 21 | ;; Now he has to mess with the file the transaction was logged into, 22 | ;; correct the typo or delete the transaction. 23 | ;; To avoid that, we log the transaction into a temporary string 24 | ;; which is commited to the log-stream only after it is succesfully executed. 25 | (%temporary-log-stream :initform (make-string-output-stream) 26 | :reader log-stream) 27 | ;; A table mapping objects to identities. Whenever we serialize an 28 | ;; object that has not been serialized before, it is entered into 29 | ;; the table, and the output is marked with the identity. Whenever 30 | ;; we serialize an object that has been serialized before, we just 31 | ;; print the identity. 32 | (%object-id-table :initarg :object-id-table :reader object-id-table) 33 | ;; We allocate object identities sequentially. 34 | (%next-object-id :initarg :next-object-id :accessor next-object-id))) 35 | 36 | ;;; Serialization of instances of STANDARD-OBJECT. 37 | 38 | (defmacro define-save-info (type &body save-info) 39 | `(defmethod save-info append ((obj ,type)) 40 | ',save-info)) 41 | 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | ;;; 44 | ;;; Open a transaction log. 45 | ;;; 46 | ;;; This is a compound function that first calls LOAD-TRANSACTION-LOG 47 | ;;; to load a transaction log from an input stream and execute the provided 48 | ;;; function on its contents, then calls MAKE-TRANSACTION-LOG which 49 | ;;; utilizes the object-table modified in effect of the first function 50 | ;;; to create a transaction log object which can be used to log further 51 | ;;; transactions. 52 | ;;; INPUT-AND-OUTPUT can be a pair (input-stream . output-stream) 53 | ;;; clobber will read and execute all the transactions from input-stream 54 | ;;; then write to output-stream the further transactions executed by the user 55 | ;;; or it can be a single pathname 56 | ;;; from which it reads and executes all the transactions 57 | ;;; then writes to the same file the further transactions executed by the user 58 | 59 | (defgeneric open-transaction-log (input-and-output function)) 60 | 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | ;;; 63 | ;;; Close a transaction log. 64 | 65 | (defun close-transaction-log (transaction-log) 66 | (close (log-stream transaction-log))) 67 | 68 | (defun transaction-log-open-p (transaction-log) 69 | (and 70 | (not (null transaction-log)) 71 | (open-stream-p (log-stream transaction-log)))) 72 | 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | ;;; 75 | ;;; Log a transaction. 76 | ;;; 77 | ;;; A transaction can be any object that the application sees fit. 78 | 79 | (defun log-transaction (transaction transaction-log) 80 | (serialize transaction transaction-log) 81 | (terpri (log-stream transaction-log)) 82 | (finish-output (log-stream transaction-log))) 83 | 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | ;;; 86 | ;;; Commit (write to final-log-stream) the transactions from 87 | ;;; the the temporary string 88 | ;;; 89 | 90 | (defun commit (transaction-log) 91 | (let ((final-log-stream (final-log-stream transaction-log))) 92 | (princ (get-output-stream-string (log-stream transaction-log)) 93 | final-log-stream) 94 | (finish-output final-log-stream))) 95 | 96 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | ;;; 98 | ;;; Get rid of the uncommitted transactions from the temporary string 99 | ;;; 100 | 101 | (defun clear-uncommitted (transaction-log) 102 | (get-output-stream-string (log-stream transaction-log))) 103 | 104 | (defmacro with-transaction-log ((var file-or-streams-pair function) &body forms) 105 | `(let ((,var (open-transaction-log ,file-or-streams-pair ,function))) 106 | (unwind-protect (progn ,@forms) 107 | (close-transaction-log ,var)))) 108 | 109 | ;;; Internal protocol 110 | 111 | 112 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 | ;;; 114 | ;;; Load a transaction log. 115 | ;;; 116 | ;;; This function reads the transaction log from the input stream. 117 | ;;; 118 | ;;; After a transaction has been read, the function supplied by the 119 | ;;; application is called in order to execute the transaction. 120 | 121 | (defgeneric load-transaction-log (input function object-table)) 122 | 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | ;;; 125 | ;;; Make the transaction log object. 126 | ;;; 127 | ;;; This function takes an output which can be a stream or a pathname 128 | ;;; and an object table, creates an object identity table 129 | ;;; based on its context, and uses the ID table to create a 130 | ;;; transaction-log object that will be used to log new transactions. 131 | 132 | (defgeneric make-transaction-log (output object-table)) 133 | 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | ;;; 136 | ;;; Serialization. 137 | ;;; 138 | ;;; What we are doing is essentially a duplication of what 139 | ;;; print-object is doing, because unfortunately, there is no portable 140 | ;;; way of using print-object to accomplish what we want. 141 | 142 | (defgeneric serialize (object transaction-log)) 143 | 144 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 145 | ;;; 146 | ;;; Serialization of instances of STANDARD-OBJECT. 147 | 148 | (defgeneric save-info (object) 149 | (:method-combination append :most-specific-last)) 150 | 151 | (defmethod save-info append ((object standard-object)) 152 | '()) 153 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | 2 | * Explanation 3 | Clobber is an alternative to so-called "object prevalence", and in 4 | particular to [[https://cl-prevalence.common-lisp.dev/][cl-prevalence]]. 5 | 6 | Clobber is both simpler, more flexible, and more robust than systems 7 | based on object prevalence. 8 | 9 | ** Simplicity 10 | Clobber is simpler because we do not take any snapshots at all. Other 11 | systems typically use a combination of transaction logs and snapshots. 12 | Clobber uses only a transaction log which is always read into an empty 13 | system. 14 | 15 | ** Flexibility 16 | Clobber is more flexible because the system itself does not define the 17 | format of a transaction. Client code can save transactions as Lisp 18 | lists, as instances of standard-object, or anything else that can be 19 | serialized. It is also more flexible because transactions can contain 20 | any object that can be serialized, including model objects. With this 21 | method, client code does not need to manipulate "manually created 22 | pointers" such as social security numbers, account numbers, membership 23 | numbers, etc. whenever it needs to execute a transaction. Instead it 24 | can use the model objects themselves such as people, accounts, 25 | automobiles and whatnot. 26 | 27 | ** Robustness 28 | Clobber is more robust because serialization of instances of (subclasses 29 | of) =standard-object= is not accomplished based on slots. Clobber considers slots to be 30 | implementation details. In other object prevalence systems, whenever 31 | the model evolves, the serialization might no longer be valid. In 32 | contrast, Clobber serializes instances of =standard-object= as a list of 33 | pairs, each one consisting of an initarg and a value. These pairs can 34 | be handled by client code in any way it sees fit. They can be handled 35 | by an =:initarg=, by =initialize-instance=, or they can be ignored. The 36 | downside of the Clobber method is that client code must specify these 37 | pairs in the form of an initarg and the name of an accessor function 38 | to be called to obtain the value used for the initarg. This 39 | inconvenience is however relatively minor, especially considering the 40 | additional robustness it buys in terms of less sensitivity to changes 41 | in the model classes. 42 | 43 | ** Design 44 | At the heart of Clobber is a mechanism for serializing objects that 45 | preserves object identity, much like the reader macros ~#=~ and ~##~, 46 | except that Clobber detects sharing within the entire transaction log, 47 | not only within a single transaction. This mechanism is what makes it 48 | possible for client code to put any old object in a transaction, while 49 | making sure that sharing is preserved. 50 | 51 | ** Examples 52 | Two examples are included - see files [[file:Documentation/demo/demo1.lisp][demo1.lisp]], [[file:Documentation/demo/demo2.lisp][demo2.lisp]] and [[file:Documentation/demo/demo3.lisp][demo3.lisp]] 53 | 54 | To run the demos - 55 | 56 | #+BEGIN_SRC lisp 57 | (ql:quickload :clobber) 58 | (in-package :clobber-demo/demo1) 59 | #+(or)(in-package :clobber-demo/demo2) 60 | #+(or)(in-package :clobber-demo/demo3) 61 | 62 | (delete-database) ; clean up 63 | (do-and-see) ; see what the database file contains after the execution of transactions 64 | #| sample output: 65 | "#2!(NEW-BANK . #3!(#4![BANK] . NIL)) 66 | #5!(NEW-BANK . #6!(#7![BANK] . NIL)) 67 | #8!(ADD-CUSTOMER . #9!(#10![PERSON :NAME #11!\"Jane\"] . #12!(#4^ . NIL))) 68 | #13!(ADD-CUSTOMER . #14!(#10^ . #15!(#7^ . NIL))) 69 | #16!(ADD-CUSTOMER . #17!(#18![PERSON :NAME #19!\"Bill\"] . #20!(#4^ . NIL))) 70 | #21!(ADD-ACCOUNT . #22!(#23![ACCOUNT :HOLDER #10^] . #24!(#4^ . NIL))) 71 | #25!(ADD-ACCOUNT . #26!(#27![ACCOUNT :HOLDER #10^] . #28!(#7^ . NIL))) 72 | #29!(ADD-ACCOUNT . #30!(#31![ACCOUNT :HOLDER #18^] . #32!(#4^ . NIL))) 73 | #33!(DEPOSIT . #34!(100 . #35!(#23^ . NIL))) 74 | #36!(DEPOSIT . #37!(200 . #38!(#27^ . NIL))) 75 | #39!(DEPOSIT . #40!(300 . #41!(#31^ . NIL))) 76 | #42!(WITHDRAW . #43!(10 . #44!(#31^ . NIL))) 77 | #45!(TRANSFER . #46!(20 . #47!(#27^ . #48!(#23^ . NIL)))) 78 | " 79 | |# 80 | ;; (reload-database-and-see) ; see that *banks* has the data freshly revived from the database file. 81 | #| sample output: 82 | ((:BANK-ID 45 :ACCOUNTS 83 | ((:ACCOUNT-ID 52 :PARENT-BANK-ID 45 :BALANCE 180 :HOLDER )) :CUSTOMERS 84 | ()) 85 | (:BANK-ID 65 :ACCOUNTS 86 | ((:ACCOUNT-ID 73 :PARENT-BANK-ID 65 :BALANCE 300 :HOLDER ) 87 | (:ACCOUNT-ID 89 :PARENT-BANK-ID 65 :BALANCE 120 :HOLDER )) 88 | :CUSTOMERS ( ))) 89 | |# 90 | 91 | #+END_SRC 92 | 93 | ** License 94 | Clobber is in the public domain in countries where it is possible to 95 | place works in the public domain explicitly. In other countries, we 96 | will distribute Clobber according to a license that lets the user do 97 | whatever he or she pleases with the code. 98 | 99 | ** Contact 100 | Send comments to robert.strandh@gmail.com 101 | 102 | A manual might be written one day. 103 | 104 | * How to use Clobber 105 | 1. If your application objects are instances of (subclasses of) =standard-object=, use =clobber:define-save-info= to tell Clobber how to serialize themr. 106 | 107 | 2. Determine the data structure your application will use to represent each transaction, and how the application will restore state from each transaction. 108 | 109 | e.g. a transaction could be a list whose =car= is a function and whose =cdr= is a list of arguments to the function. State can be restored from such a transaction through =(lambda (txn) (apply (first txn) (rest txn)))= 110 | 111 | 3. When you update your application state - 112 | 1. Use =clobber:with-transaction-log= to create a transaction log. 113 | 114 | 2. Within the body of =clobber:with-transaction-log=, use =clobber:log-transaction= to persist the changes to your application state. You may wish to define a helper function or macro for this. 115 | 116 | If =clobber:with-transaction-log= is for some reason unsuitable - 117 | 118 | 1. Use =clobber:open-transaction-log= to create a transaction log, usually stored in a special variable. 119 | 120 | 2. Use =clobber:log-transaction= to persist changes to your application state. 121 | 122 | 3. When the transaction log is no longer required, close it using =clobber:close-transaction-log=. 123 | 124 | * Reference 125 | *** =define-save-info (type &body save-info)= :macro: 126 | *** =with-transaction-log ((var file function) &body forms)= :macro: 127 | *** =open-transaction-log (filename function)= :function: 128 | *** =log-transaction (transaction transaction-log)= :function: 129 | *** =close-transaction-log (transaction-log)= :function: 130 | *** =transaction-log-open-p (transaction-log)= :function: 131 | -------------------------------------------------------------------------------- /Documentation/demo/demo3.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:clobber-demo/demo3 2 | (:use #:common-lisp #:clobber-demo/common) 3 | (:import-from #:clobber-demo/demo2 4 | #:*operator* 5 | #:*comment* 6 | #:with-comment 7 | #:transaction 8 | #:function-name 9 | #:arguments 10 | #:creator 11 | #:comment 12 | #:*transactions* 13 | #:log-to-list 14 | #:commit-to-list 15 | #:clear-uncommitted-to-list) 16 | (:export #:with-atomic-logging 17 | 18 | #:start 19 | #:execute 20 | 21 | #:log-transaction 22 | #:commit 23 | #:clear-uncommitted 24 | #:*atomic-logging*)) 25 | 26 | (in-package #:clobber-demo/demo3) 27 | 28 | ;;; Demonstration of multiple (execute ...) forms atomic logging 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;; 32 | ;;; Starting and stopping. 33 | 34 | (defun start (filename) 35 | (setf *banks* '()) 36 | (setf *transactions* '()) 37 | (setf *transaction-log* 38 | (clobber:open-transaction-log 39 | filename 40 | (lambda (transaction) 41 | (apply (function-name transaction) 42 | (arguments transaction)) 43 | (log-to-list transaction) 44 | (commit-to-list))))) 45 | 46 | (defun log-transaction (transaction) 47 | (clobber:log-transaction transaction ; log to temporary buffer 48 | *transaction-log*) 49 | (log-to-list transaction)) ; log to temporary list 50 | 51 | (defun commit () 52 | (clobber:commit *transaction-log*) ; commit to file 53 | (commit-to-list)) 54 | 55 | (defun clear-uncommitted () 56 | (clobber:clear-uncommitted *transaction-log*) 57 | (clear-uncommitted-to-list)) 58 | 59 | ;; *atomic-logging* is true when we're inside 60 | ;; the body of the with-atomic-logging macro 61 | (defvar *atomic-logging* nil) 62 | 63 | ;;; For convenience, 64 | ;;; when not inside the body of the with-atomic-logging macro 65 | ;;; the function #'execute calls (clear-uncommitted) and (commit) 66 | ;;; so that the execution of that single transaction is atomic 67 | ;;; without the need to wrap it with with-atomic-logging 68 | ;;; and without the need for the application programmer to manually 69 | ;;; call (clear-uncommitted) and (commit). 70 | 71 | (defun execute (transaction-function &rest arguments) 72 | (let ((transaction (make-instance 'transaction 73 | :function-name transaction-function 74 | :arguments arguments))) 75 | ;; if we're inside a with-atomic-logging block no need to 76 | ;; (clear-uncommitted) because the macro with-atomic-logging 77 | ;; will handle it at the beginning of its block. 78 | (unless *atomic-logging* 79 | (clear-uncommitted)) 80 | ;; log to temporary buffer 81 | (log-transaction transaction) 82 | ;; execute 83 | (apply transaction-function arguments) 84 | ;; then commit if successful. 85 | ;; if we're inside a with-atomic-logging block no need to 86 | ;; (commit) because the macro with-atomic-logging 87 | ;; will handle it at the end of its block. 88 | (unless *atomic-logging* 89 | (commit)))) 90 | 91 | (defmacro with-atomic-logging (options &body body) 92 | ;; options is unused, but I added it because emacs indents 93 | ;; the form better if it sees the () in (with-atomic-logging () ...) 94 | ;; options could contain a specific database, as we'll see in demo4 95 | ;; which deals with an abstraction for databases so that an application 96 | ;; can use multiple databases at the same time, and also offers 97 | ;; a cleaner interface for application writers 98 | `(prog2 (clear-uncommitted) 99 | (let ((*atomic-logging* t)) 100 | ,@body) 101 | (commit))) 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;;; 105 | ;;; The actual application 106 | ;;; now has an atomic block: 107 | 108 | (defun do-things () 109 | (let ((b1 (make-instance 'bank)) 110 | (b2 (make-instance 'bank)) 111 | (jane (make-instance 'person :name "Jane")) 112 | (bill (make-instance 'person :name "Bill"))) 113 | (execute 'new-bank b1) 114 | (execute 'new-bank b2) 115 | (execute 'add-customer jane b1) 116 | (with-comment "What does bank 2 have that bank 1 does not?" 117 | (execute 'add-customer jane b2)) 118 | (execute 'add-customer bill b1) 119 | (let ((a1 (make-instance 'account :holder jane)) 120 | (a2 (make-instance 'account :holder jane)) 121 | (a3 (make-instance 'account :holder bill))) 122 | (execute 'add-account a1 b1) 123 | (execute 'add-account a2 b2) 124 | (execute 'add-account a3 b1) 125 | (with-comment "Gee, I wish they would deposit more money!" 126 | (execute 'deposit 100 a1)) 127 | (execute 'deposit 200 a2) 128 | (execute 'deposit 300 a3) 129 | (handler-case 130 | (with-atomic-logging () ; <- atomic block 131 | ;; none of the withdrawals in this block will be logged, 132 | ;; because an error happened before executing successfully 133 | ;; the last transaction in the block 134 | (execute 'withdraw 10 a3) ; <- this withdrawal is executed in the application 135 | ;; and changes the objects, but it will not be logged. 136 | ;; So after fixing the bug in the atomic logging block 137 | ;; a simple reload-database command in the application can revert 138 | ;; the state of all objects. 139 | (execute 'withdraw (error "Some bug") a3) 140 | (execute 'withdraw 10 a3) 141 | (execute 'withdraw 10 a3)) 142 | (error (c) "the buggy atomic block was ignored")) 143 | (execute 'transfer 20 a2 a1)))) 144 | 145 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 146 | ;;; 147 | ;;; Demonstrating the application 148 | ;;; 149 | ;;; (delete-database) ; clean up 150 | ;;; (do-and-see) ; see what the database file contains after the execution of transactions 151 | ;;; (reload-database) ; see that *banks* has the data freshly revived from the database file. 152 | 153 | 154 | (defvar *database-file* (merge-pathnames "demo3-database" (user-homedir-pathname))) 155 | 156 | (defun do-and-see () 157 | (start *database-file*) 158 | (do-things) 159 | ;;; inspect the file to see the transaction log 160 | (with-open-file (stream *database-file*) 161 | (let ((data (make-string (file-length stream)))) 162 | (read-sequence data stream) 163 | data))) 164 | 165 | (defun reload-database () 166 | (stop) 167 | (start *database-file*)) 168 | 169 | (defun reload-database-and-see () 170 | (reload-database) 171 | *banks*) 172 | 173 | (defun delete-database () 174 | (stop) 175 | (when (probe-file *database-file*) 176 | (delete-file *database-file*))) 177 | 178 | --------------------------------------------------------------------------------