1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: transactions.cl
6 ;;;; Purpose: Transaction support
7 ;;;; Programmers: Marc Battyani
8 ;;;; Date Started: Apr 2002
10 ;;;; $Id: transactions.lisp,v 1.2 2002/10/14 15:25:15 kevin Exp $
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; CLSQL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
19 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
20 (in-package :clsql-sys)
22 ;; I removed the USQL transaction stuff to put a smaller, lighter one (MB)
24 (defclass transaction ()
25 ((commit-hooks :initform () :accessor commit-hooks)
26 (rollback-hooks :initform () :accessor rollback-hooks)
27 (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited
29 (defgeneric database-start-transaction (database))
30 (defmethod database-start-transaction ((database closed-database))
31 (error 'clsql-closed-database-error database))
33 (defmethod database-start-transaction (database)
34 (unless (transaction database)
35 (setf (transaction database) (make-instance 'transaction)))
36 (when (= (incf (transaction-level database)) 1)
37 (let ((transaction (transaction database)))
38 (setf (commit-hooks transaction) nil
39 (rollback-hooks transaction) nil
40 (status transaction) nil)
41 (execute-command "BEGIN" :database database))))
43 (defgeneric database-end-transaction (database))
44 (defmethod database-end-transaction ((database closed-database))
45 (error 'clsql-closed-database-error database))
47 (defmethod database-end-transaction (database)
48 (if (> (transaction-level database) 0)
49 (when (zerop (decf (transaction-level database)))
50 (let ((transaction (transaction database)))
51 (if (eq (status transaction) :commited)
53 (execute-command "COMMIT" :database database)
54 (map nil #'funcall (commit-hooks transaction)))
55 (unwind-protect ;status is not :commited
56 (execute-command "ROLLBACK" :database database)
57 (map nil #'funcall (rollback-hooks transaction))))))
58 (warn "Continue without commit."
60 :format-control "Cannot commit transaction against ~A because there is no transaction in progress."
61 :format-arguments (list database))))
63 (defun rollback-transaction (database)
64 (when (and (transaction database)(not (status (transaction database))))
65 (setf (status (transaction database)) :rolled-back)))
67 (defun commit-transaction (database)
68 (when (and (transaction database)(not (status (transaction database))))
69 (setf (status (transaction database)) :commited)))
71 (defun add-transaction-commit-hook (database commit-hook)
72 (when (transaction database)
73 (push commit-hook (commit-hooks (transaction database)))))
75 (defun add-transaction-rollback-hook (database rollback-hook)
76 (when (transaction database)
77 (push rollback-hook (rollback-hooks (transaction database)))))
79 (defmacro with-transaction ((&key (database '*default-database*)) &rest body)
80 (let ((db (gensym "db-")))
81 `(let ((,db ,database))
84 (database-start-transaction ,db)
86 (commit-transaction ,db))
87 (database-end-transaction ,db)))))