1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; Transaction support
8 ;;;; This file is part of CLSQL.
10 ;;;; CLSQL users are granted the rights to distribute and use this software
11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
13 ;;;; *************************************************************************
15 (in-package #:clsql-sys)
17 (defclass transaction ()
18 ((commit-hooks :initform () :accessor commit-hooks)
19 (rollback-hooks :initform () :accessor rollback-hooks)
20 (previous-autocommit :initarg :previous-autocommit
21 :reader previous-autocommit)
22 (status :initform nil :accessor transaction-status
23 :documentation "nil or :committed")))
25 (defun add-transaction-commit-hook (database commit-hook)
26 (when (transaction database)
27 (push commit-hook (commit-hooks (transaction database)))))
29 (defun add-transaction-rollback-hook (database rollback-hook)
30 (when (transaction database)
31 (push rollback-hook (rollback-hooks (transaction database)))))
33 (defmethod database-start-transaction ((database database))
34 (unless (transaction database)
35 (setf (transaction database)
36 (make-instance 'transaction :previous-autocommit
37 (database-autocommit database))))
38 (setf (database-autocommit database) nil)
39 (when (= (incf (transaction-level database) 1))
40 (let ((transaction (transaction database)))
41 (setf (commit-hooks transaction) nil
42 (rollback-hooks transaction) nil
43 (transaction-status transaction) nil)
44 (unless (eq :oracle (database-underlying-type database))
45 (execute-command "BEGIN" :database database)))))
47 (defmethod database-commit-transaction ((database database))
48 (with-slots (transaction transaction-level autocommit) database
49 (if (plusp transaction-level)
50 (when (zerop (decf transaction-level))
51 (execute-command "COMMIT" :database database)
52 (setf autocommit (previous-autocommit transaction))
53 (map nil #'funcall (commit-hooks transaction)))
56 (format nil "Cannot commit transaction against ~A because there is no transaction in progress."
59 (defmethod database-abort-transaction ((database database))
60 (with-slots (transaction transaction-level autocommit) database
61 (if (plusp transaction-level)
62 (when (zerop (decf transaction-level))
64 (execute-command "ROLLBACK" :database database)
65 (setf autocommit (previous-autocommit transaction))
66 (map nil #'funcall (rollback-hooks transaction))))
69 (format nil "Cannot abort transaction against ~A because there is no transaction in progress."
72 (defun mark-transaction-committed (database)
73 (when (and (transaction database)
74 (not (transaction-status (transaction database))))
75 (setf (transaction-status (transaction database)) :committed)))
77 (defmacro with-transaction ((&key (database '*default-database*)) &rest body)
78 "Starts a transaction in the database specified by DATABASE,
79 which is *DEFAULT-DATABASE* by default, and executes BODY within
80 that transaction. If BODY aborts or throws, DATABASE is rolled
81 back and otherwise the transaction is committed."
82 (let ((db (gensym "db-")))
83 `(let ((,db ,database))
86 (database-start-transaction ,db)
89 (mark-transaction-committed ,db))
90 (if (eq (transaction-status (transaction ,db)) :committed)
91 (database-commit-transaction ,db)
92 (database-abort-transaction ,db))))))
94 (defun commit (&key (database *default-database*))
95 "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
96 currently within the scope of a transaction, commits changes made
97 since the transaction began."
98 (database-commit-transaction database))
100 (defun rollback (&key (database *default-database*))
101 "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
102 currently within the scope of a transaction, rolls back changes
103 made since the transaction began."
104 (database-abort-transaction database))
106 (defun start-transaction (&key (database *default-database*))
107 "Starts a transaction block on DATABASE which defaults to
108 *DEFAULT-DATABASE* and which continues until ROLLBACK or COMMIT
110 (unless (in-transaction-p :database database)
111 (database-start-transaction database)))
113 (defun in-transaction-p (&key (database *default-database*))
114 "A predicate to test whether DATABASE, which defaults to
115 *DEFAULT-DATABASE*, is currently within the scope of a
117 (and database (transaction database) (= (transaction-level database) 1)))
119 (defun set-autocommit (value &key (database *default-database*))
120 "Sets autocommit on or off. Returns old value of of autocommit flag."
121 (let ((old-value (database-autocommit database)))
122 (setf (database-autocommit database) value)
123 (database-autocommit database)