sql/transaction.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; Transaction support
   7 ;;;;
   8 ;;;; This file is part of CLSQL.
   9 ;;;;
  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 ;;;; *************************************************************************
  14
  15 (in-package #:clsql-sys)
  16
  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")))
  24
  25 (defun add-transaction-commit-hook (commit-hook &key
  26                                     (database *default-database*))
  27   "Adds COMMIT-HOOK, which should a designator for a function
  28 with no required arguments, to the list of hooks run when COMMIT
  29 is called on DATABASE which defaults to *DEFAULT-DATABASE*."
  30   (when (transaction database)
  31     (push commit-hook (commit-hooks (transaction database)))))
  32
  33 (defun add-transaction-rollback-hook (rollback-hook
  34                                       &key (database *default-database*))
  35   "Adds ROLLBACK-HOOK, which should a designator for a function
  36 with no required arguments, to the list of hooks run when ROLLBACK
  37 is called on DATABASE which defaults to *DEFAULT-DATABASE*."
  38   (when (transaction database)
  39     (push rollback-hook (rollback-hooks (transaction database)))))
  40
  41 (defmethod database-start-transaction ((database database))
  42   (unless (transaction database)
  43     (setf (transaction database)
  44           (make-instance 'transaction :previous-autocommit
  45                          (database-autocommit database))))
  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 it's 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         (when (zerop (decf transaction-level))
  64           (case (database-underlying-type database)
  65             (:mssql (execute-command "COMMIT TRANSACTION" :database database))
  66             (t (execute-command "COMMIT" :database database)))
  67           (setf autocommit (previous-autocommit transaction))
  68           (map nil #'funcall (commit-hooks transaction)))
  69         (warn 'sql-warning
  70               :message
  71               (format nil "Cannot commit transaction against ~A because there is no transaction in progress."
  72                       database)))))
  73
  74 (defmethod database-abort-transaction ((database database))
  75   (with-slots (transaction transaction-level autocommit) database
  76     (if (plusp transaction-level)
  77         (when (zerop (decf transaction-level))
  78           (unwind-protect
  79                (case (database-underlying-type database)
  80                  (:mssql (execute-command "ROLLBACK TRANSACTION" :database database))
  81                  (t (execute-command "ROLLBACK" :database database)))
  82             (setf autocommit (previous-autocommit transaction))
  83             (map nil #'funcall (rollback-hooks transaction))))
  84         (warn 'sql-warning
  85               :message
  86               (format nil "Cannot abort transaction against ~A because there is no transaction in progress."
  87                       database)))))
  88
  89 (defun mark-transaction-committed (database)
  90   (when (and (transaction database)
  91              (not (transaction-status (transaction database))))
  92     (setf (transaction-status (transaction database)) :committed)))
  93
  94 (defmacro with-transaction ((&key (database '*default-database*)) &rest body)
  95   "Starts a transaction in the database specified by DATABASE,
  96 which is *DEFAULT-DATABASE* by default, and executes BODY within
  97 that transaction. If BODY aborts or throws, DATABASE is rolled
  98 back and otherwise the transaction is committed."
  99   (let ((db (gensym "db-")))
 100     `(let ((,db ,database))
 101       (unwind-protect
 102            (prog2
 103              (database-start-transaction ,db)
 104              (progn
 105                ,@body)
 106              (mark-transaction-committed ,db))
 107         (if (eq (transaction-status (transaction ,db)) :committed)
 108             (database-commit-transaction ,db)
 109             (database-abort-transaction ,db))))))
 110
 111 (defun commit (&key (database *default-database*))
 112   "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
 113 currently within the scope of a transaction, commits changes made
 114 since the transaction began."
 115   (database-commit-transaction database)
 116   nil)
 117
 118 (defun rollback (&key (database *default-database*))
 119   "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
 120 currently within the scope of a transaction, rolls back changes
 121 made since the transaction began."
 122   (database-abort-transaction database)
 123   nil)
 124
 125 (defun start-transaction (&key (database *default-database*))
 126   "Starts a transaction block on DATABASE which defaults to
 127 *DEFAULT-DATABASE* and which continues until ROLLBACK or COMMIT
 128 are called."
 129   (unless (in-transaction-p :database database)
 130     (database-start-transaction database))
 131   nil)
 132
 133 (defun in-transaction-p (&key (database *default-database*))
 134   "A predicate to test whether DATABASE, which defaults to
 135 *DEFAULT-DATABASE*, is currently within the scope of a
 136 transaction."
 137   (and database (transaction database) (= (transaction-level database) 1)))
 138
 139 (defun set-autocommit (value &key (database *default-database*))
 140   "Turns autocommit off for DATABASE if VALUE is NIL, and
 141 otherwise turns it on. Returns the old value of autocommit flag.
 142 For RDBMS (such as Oracle) which don't automatically commit
 143 changes, turning autocommit on has the effect of explicitly
 144 committing changes made whenever SQL statements are executed.
 145 Autocommit is turned on by default."
 146   (let ((old-value (database-autocommit database)))
 147     (setf (database-autocommit database) value)
 148     (database-autocommit database)
 149     old-value))
 150