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