sql/transaction.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; Transaction support
   5 ;;;;
   6 ;;;; This file is part of CLSQL.
   7 ;;;;
   8 ;;;; CLSQL users are granted the rights to distribute and use this software
   9 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  10 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  11 ;;;; *************************************************************************
  12
  13 (in-package #:clsql-sys)
  14
  15 (defclass transaction ()
  16   ((commit-hooks :initform () :accessor commit-hooks)
  17    (rollback-hooks :initform () :accessor rollback-hooks)
  18    (previous-autocommit :initarg :previous-autocommit
  19                         :reader previous-autocommit)
  20    (status :initform nil :accessor transaction-status
  21            :documentation "nil or :committed")))
  22
  23 (defun add-transaction-commit-hook (commit-hook &key
  24                                     (database *default-database*))
  25   "Adds COMMIT-HOOK, which should a designator for a function
  26 with no required arguments, to the list of hooks run when COMMIT
  27 is called on DATABASE which defaults to *DEFAULT-DATABASE*."
  28   (when (transaction database)
  29     (push commit-hook (commit-hooks (transaction database)))))
  30
  31 (defun add-transaction-rollback-hook (rollback-hook
  32                                       &key (database *default-database*))
  33   "Adds ROLLBACK-HOOK, which should a designator for a function
  34 with no required arguments, to the list of hooks run when ROLLBACK
  35 is called on DATABASE which defaults to *DEFAULT-DATABASE*."
  36   (when (transaction database)
  37     (push rollback-hook (rollback-hooks (transaction database)))))
  38
  39 (defmethod database-start-transaction ((database database))
  40   (unless (transaction database)
  41     (setf (transaction database)
  42           (make-instance 'transaction :previous-autocommit
  43                          (database-autocommit database))))
  44   ;; TODO: database-autocommit might get lost in some scenarios
  45   ;; when pooling connections
  46   (setf (database-autocommit database) nil)
  47   (when (= (incf (transaction-level database)) 1)
  48     (let ((transaction (transaction database)))
  49       (setf (commit-hooks transaction) nil
  50             (rollback-hooks transaction) nil
  51             (transaction-status transaction) nil)
  52       (case (database-underlying-type database)
  53         (:oracle nil)
  54         (:mssql (execute-command "BEGIN TRANSACTION" :database database))
  55         (t (execute-command "BEGIN" :database database))))))
  56
  57 ;;ODBC should potentially be using the following scheme for transactions:
  58 ;; turn off autocommit for begin. then use sqlendtran (or maybe sqltransact)
  59 ;; whatever is appropriate for this version of odbc.
  60 (defmethod database-commit-transaction ((database database))
  61   (with-slots (transaction transaction-level autocommit) database
  62     (if (plusp transaction-level)
  63         (if (zerop (decf transaction-level))
  64             (progn
  65               (case (database-underlying-type database)
  66                 (:mssql (execute-command "COMMIT TRANSACTION" :database database))
  67                 (t (execute-command "COMMIT" :database database)))
  68               (setf autocommit (previous-autocommit transaction))
  69               (map nil #'funcall (commit-hooks transaction)))
  70             (setf (transaction-status (transaction database)) nil))
  71         (warn 'sql-warning
  72               :message
  73               (format nil "Cannot commit transaction against ~A because there is no transaction in progress."
  74                       database)))))
  75
  76 (defmethod database-abort-transaction ((database database))
  77   (with-slots (transaction transaction-level autocommit) database
  78     (if (plusp transaction-level)
  79         (when (zerop (decf transaction-level))
  80           (unwind-protect
  81                (case (database-underlying-type database)
  82                  (:mssql (execute-command "ROLLBACK TRANSACTION" :database database))
  83                  (t (execute-command "ROLLBACK" :database database)))
  84             (setf autocommit (previous-autocommit transaction))
  85             (map nil #'funcall (rollback-hooks transaction))))
  86         (warn 'sql-warning
  87               :message
  88               (format nil "Cannot abort transaction against ~A because there is no transaction in progress."
  89                       database)))))
  90
  91 (defun mark-transaction-committed (database)
  92   (when (and (transaction database)
  93              (not (transaction-status (transaction database))))
  94     (setf (transaction-status (transaction database)) :committed)))
  95
  96 (defmacro with-transaction ((&key (database '*default-database*)) &body body)
  97   "Starts a transaction in the database specified by DATABASE,
  98 which is *DEFAULT-DATABASE* by default, and executes BODY within
  99 that transaction. If BODY aborts or throws, DATABASE is rolled
 100 back and otherwise the transaction is committed."
 101   (let ((db (gensym "db-")))
 102     `(let ((,db ,database))
 103       (unwind-protect
 104            (prog2
 105              (database-start-transaction ,db)
 106              (progn
 107                ,@body)
 108              (mark-transaction-committed ,db))
 109         (if (eq (transaction-status (transaction ,db)) :committed)
 110             (database-commit-transaction ,db)
 111             (database-abort-transaction ,db))))))
 112
 113 (defun commit (&key (database *default-database*))
 114   "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
 115 currently within the scope of a transaction, commits changes made
 116 since the transaction began."
 117   (database-commit-transaction database)
 118   nil)
 119
 120 (defun rollback (&key (database *default-database*))
 121   "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
 122 currently within the scope of a transaction, rolls back changes
 123 made since the transaction began."
 124   (database-abort-transaction database)
 125   nil)
 126
 127 (defun start-transaction (&key (database *default-database*))
 128   "Starts a transaction block on DATABASE which defaults to
 129 *DEFAULT-DATABASE* and which continues until ROLLBACK or COMMIT
 130 are called."
 131   (unless (in-transaction-p :database database)
 132     (database-start-transaction database))
 133   nil)
 134
 135 (defun in-transaction-p (&key (database *default-database*))
 136   "A predicate to test whether DATABASE, which defaults to
 137 *DEFAULT-DATABASE*, is currently within the scope of a
 138 transaction."
 139   (and database (transaction database) (= (transaction-level database) 1)))
 140
 141 (defun set-autocommit (value &key (database *default-database*))
 142   "Turns autocommit off for DATABASE if VALUE is NIL, and
 143 otherwise turns it on. Returns the old value of autocommit flag.
 144 For RDBMS (such as Oracle) which don't automatically commit
 145 changes, turning autocommit on has the effect of explicitly
 146 committing changes made whenever SQL statements are executed.
 147 Autocommit is turned on by default."
 148   (let ((old-value (database-autocommit database)))
 149     (setf (database-autocommit database) value)
 150     (database-autocommit database)
 151     old-value))
 152