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 (defmethod database-commit-transaction ((database database))
  58   (with-slots (transaction transaction-level autocommit) database
  59     (if (plusp transaction-level)
  60         (when (zerop (decf transaction-level))
  61           (execute-command "COMMIT" :database database)
  62           (setf autocommit (previous-autocommit transaction))
  63           (map nil #'funcall (commit-hooks transaction)))
  64         (warn 'sql-warning
  65               :message
  66               (format nil "Cannot commit transaction against ~A because there is no transaction in progress."
  67                       database)))))
  68
  69 (defmethod database-abort-transaction ((database database))
  70   (with-slots (transaction transaction-level autocommit) database
  71     (if (plusp transaction-level)
  72         (when (zerop (decf transaction-level))
  73           (unwind-protect
  74                (execute-command "ROLLBACK" :database database)
  75             (setf autocommit (previous-autocommit transaction))
  76             (map nil #'funcall (rollback-hooks transaction))))
  77         (warn 'sql-warning
  78               :message
  79               (format nil "Cannot abort transaction against ~A because there is no transaction in progress."
  80                       database)))))
  81
  82 (defun mark-transaction-committed (database)
  83   (when (and (transaction database)
  84              (not (transaction-status (transaction database))))
  85     (setf (transaction-status (transaction database)) :committed)))
  86
  87 (defmacro with-transaction ((&key (database '*default-database*)) &rest body)
  88   "Starts a transaction in the database specified by DATABASE,
  89 which is *DEFAULT-DATABASE* by default, and executes BODY within
  90 that transaction. If BODY aborts or throws, DATABASE is rolled
  91 back and otherwise the transaction is committed."
  92   (let ((db (gensym "db-")))
  93     `(let ((,db ,database))
  94       (unwind-protect
  95            (prog2
  96              (database-start-transaction ,db)
  97              (progn
  98                ,@body)
  99              (mark-transaction-committed ,db))
 100         (if (eq (transaction-status (transaction ,db)) :committed)
 101             (database-commit-transaction ,db)
 102             (database-abort-transaction ,db))))))
 103
 104 (defun commit (&key (database *default-database*))
 105   "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
 106 currently within the scope of a transaction, commits changes made
 107 since the transaction began."
 108   (database-commit-transaction database)
 109   nil)
 110
 111 (defun rollback (&key (database *default-database*))
 112   "If DATABASE, which defaults to *DEFAULT-DATABASE*, is
 113 currently within the scope of a transaction, rolls back changes
 114 made since the transaction began."
 115   (database-abort-transaction database)
 116   nil)
 117
 118 (defun start-transaction (&key (database *default-database*))
 119   "Starts a transaction block on DATABASE which defaults to
 120 *DEFAULT-DATABASE* and which continues until ROLLBACK or COMMIT
 121 are called."
 122   (unless (in-transaction-p :database database)
 123     (database-start-transaction database))
 124   nil)
 125
 126 (defun in-transaction-p (&key (database *default-database*))
 127   "A predicate to test whether DATABASE, which defaults to
 128 *DEFAULT-DATABASE*, is currently within the scope of a
 129 transaction."
 130   (and database (transaction database) (= (transaction-level database) 1)))
 131
 132 (defun set-autocommit (value &key (database *default-database*))
 133   "Turns autocommit off for DATABASE if VALUE is NIL, and
 134 otherwise turns it on. Returns the old value of autocommit flag.
 135 For RDBMS (such as Oracle) which don't automatically commit
 136 changes, turning autocommit on has the effect of explicitly
 137 committing changes made whenever SQL statements are executed.
 138 Autocommit is turned on by default."
 139   (let ((old-value (database-autocommit database)))
 140     (setf (database-autocommit database) value)
 141     (database-autocommit database)
 142     old-value))
 143