1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: transactions.cl
6 ;;;; Purpose: Transaction support
7 ;;;; Programmers: Kevin M. Rosenberg, Marc Battyani
8 ;;;; Date Started: Apr 2002
10 ;;;; $Id: transactions.cl,v 1.2 2002/05/07 10:19:13 marc.battyani Exp $
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
13 ;;;; and Copyright (c) 2000-2002 by onShore Development
15 ;;;; CLSQL users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
18 ;;;; *************************************************************************
20 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
21 (in-package :clsql-sys)
23 ;; I removed the USQL transaction stuff to put a smaller, lighter one (MB)
25 (defclass transaction ()
26 ((commit-hooks :initform () :accessor commit-hooks)
27 (rollback-hooks :initform () :accessor rollback-hooks)
28 (aborted :initform nil :accessor aborted)))
30 (defmethod database-start-transaction ((database closed-database))
31 (signal-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 (aborted transaction) nil)
41 (execute-command "BEGIN" :database database))))
43 (defmethod database-end-transaction ((database closed-database) commit)
44 (signal-closed-database-error database))
46 (defmethod database-end-transaction (database commit)
48 (setf (aborted (transaction database)) t))
49 (if (> (transaction-level database) 0)
50 (when (zerop (decf (transaction-level database)))
51 (let ((transaction (transaction database)))
52 (if (aborted transaction)
54 (execute-command "ROLLBACK" :database database)
55 (map nil #'funcall (rollback-hooks database)))
57 (execute-command "COMMIT" :database database)
58 (map nil #'funcall (commit-hooks transaction))))))
59 (warn "Continue without commit."
61 :format-control "Cannot commit transaction against ~A because there is no transaction in progress."
62 :format-arguments (list database))))
64 (defun abort-transaction (database)
65 (when (transaction database)
66 (setf (aborted (transaction database)) t)))
68 (defun add-transaction-commit-hook (database abort-hook)
69 (when (transaction database)
70 (push abort-hook (abort-hooks (transaction database)))))
72 (defun add-transaction-rollback-hook (database rollback-hook)
73 (when (transaction database)
74 (push rollback-hook (rollback-hooks (transaction database)))))
76 (defmacro with-transaction ((&key (database '*default-database*) abort-function)
78 (let ((db (gensym "db"))
79 (commit (gensym "commit-")))
80 `(let ((,db ,database)
84 (database-start-transaction ,db)
88 (database-end-transaction ,db ,commit)))))