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.1 2002/09/30 10:19:23 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 (defmethod database-start-transaction ((database closed-database))
30 (error 'clsql-closed-database-error database))
32 (defmethod database-start-transaction (database)
33 (unless (transaction database)
34 (setf (transaction database) (make-instance 'transaction)))
35 (when (= (incf (transaction-level database)) 1)
36 (let ((transaction (transaction database)))
37 (setf (commit-hooks transaction) nil
38 (rollback-hooks transaction) nil
39 (status transaction) nil)
40 (execute-command "BEGIN" :database database))))
42 (defmethod database-end-transaction ((database closed-database))
43 (error 'clsql-closed-database-error database))
45 (defmethod database-end-transaction (database)
46 (if (> (transaction-level database) 0)
47 (when (zerop (decf (transaction-level database)))
48 (let ((transaction (transaction database)))
49 (if (eq (status transaction) :commited)
51 (execute-command "COMMIT" :database database)
52 (map nil #'funcall (commit-hooks transaction)))
53 (unwind-protect ;status is not :commited
54 (execute-command "ROLLBACK" :database database)
55 (map nil #'funcall (rollback-hooks transaction))))))
56 (warn "Continue without commit."
58 :format-control "Cannot commit transaction against ~A because there is no transaction in progress."
59 :format-arguments (list database))))
61 (defun rollback-transaction (database)
62 (when (and (transaction database)(not (status (transaction database))))
63 (setf (status (transaction database)) :rolled-back)))
65 (defun commit-transaction (database)
66 (when (and (transaction database)(not (status (transaction database))))
67 (setf (status (transaction database)) :commited)))
69 (defun add-transaction-commit-hook (database commit-hook)
70 (when (transaction database)
71 (push commit-hook (commit-hooks (transaction database)))))
73 (defun add-transaction-rollback-hook (database rollback-hook)
74 (when (transaction database)
75 (push rollback-hook (rollback-hooks (transaction database)))))
77 (defmacro with-transaction ((&key (database '*default-database*)) &rest body)
78 (let ((db (gensym "db-")))
79 `(let ((,db ,database))
82 (database-start-transaction ,db)
84 (commit-transaction ,db))
85 (database-end-transaction ,db)))))