sql/transactions.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          transactions.cl
   6 ;;;; Purpose:       Transaction support
   7 ;;;; Programmers:   Kevin M. Rosenberg based
   8 ;;;;                 Original code by onShore Development Inc.
   9 ;;;; Date Started:  Apr 2002
  10 ;;;;
  11 ;;;; $Id: transactions.cl,v 1.1 2002/04/27 21:48:08 kevin Exp $
  12 ;;;;
  13 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  14 ;;;; and Copyright (c) 2000-2002 by onShore Development
  15 ;;;;
  16 ;;;; CLSQL users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  19 ;;;; *************************************************************************
  20
  21 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  22 (in-package :clsql-sys)
  23
  24 ;; This code is copied verbatim from UncommonSQL. It is intended to
  25 ;; provide transaction support to CLSQL users that, for whatever reason,
  26 ;; don't want to use the upcoming UncommonSQL/CLSQL combination.
  27
  28 (defmethod database-start-transaction ((database closed-database))
  29   (signal-closed-database-error database))
  30
  31 (defmethod database-start-transaction (database)
  32   (unless database
  33     (error 'clsql-nodb-error))
  34   (with-accessors ((level transaction-level))
  35     database
  36     (incf level)
  37     (when (= level 1)
  38       (execute-command "BEGIN" :database database))))
  39
  40 (defmethod database-commit-transaction ((database closed-database))
  41   (signal-closed-database-error database))
  42
  43 (defmethod database-commit-transaction (database)
  44   (with-accessors ((level transaction-level))
  45     database
  46     (if (< 0 level)
  47         (progn
  48           (decf level)
  49           (when (= level 0)
  50             (execute-command "COMMIT" :database database)))
  51       (warn "Continue without commit."
  52             'clsql-simple-error
  53             :format-control "Cannot commit transaction against ~A because there is no transaction in progress."
  54             :format-arguments (list database)))))
  55
  56 (defmethod database-abort-transaction ((database closed-database))
  57   (signal-closed-database-error database))
  58
  59 (defmethod database-abort-transaction (database)
  60   (with-accessors ((level transaction-level))
  61     database
  62   (if (< 0 level)
  63       (progn
  64         (setf level 0)
  65         (execute-command "ROLLBACK" :database database))
  66       (warn "Continue without abort."
  67               'clsql-simple-error
  68               :format-control "Cannot abort transaction against ~A because there is no transaction in progress."
  69               :format-arguments (list database)))))
  70
  71 (defvar *transaction-level* 0)
  72 (defvar *transaction-id* nil)
  73
  74 (defvar *transaction-aborts* (make-hash-table))
  75 (defvar *transaction-completes* (make-hash-table))
  76
  77 (defun on-txn-abort (fn)
  78   (push (cons *transaction-level* fn) (gethash *transaction-id* *transaction-aborts*)))
  79
  80 (defun on-txn-complete (fn)
  81   (if (> *transaction-level* 0)
  82       (push fn (gethash *transaction-id* *transaction-completes*))
  83       (warn "Cannot define on-txn-complete actions outside of transactions.")))
  84
  85 (defun run-abort-hooks ()
  86   (let ((remainder (remove-if (lambda (hook)
  87                                 (< (car hook) *transaction-level*))
  88                               (gethash *transaction-id* *transaction-aborts*))))
  89     (mapcar #'(lambda (hook)
  90                 (funcall (cdr hook)))
  91             (gethash *transaction-id* *transaction-aborts*))
  92     (setf (gethash *transaction-id* *transaction-aborts*) remainder)))
  93
  94
  95 (defmacro with-transaction ((&key database)
  96                             &rest body)
  97   (let ((dbsym (gensym "db"))
  98         (transym (gensym "tran")))
  99     `(let ((,dbsym (or ,database *default-database*))
 100            (,transym nil)
 101            (*transaction-id* (or *transaction-id*
 102                                  (gensym "txn")))
 103            (*transaction-level* (1+ *transaction-level*)))
 104       (unwind-protect
 105         (progn
 106           (database-start-transaction ,dbsym)
 107           (setf ,transym t)
 108           ,@body
 109           (database-commit-transaction ,dbsym)
 110           (setf ,transym nil))
 111         (if ,transym
 112             (progn                      ; was aborted
 113               (database-abort-transaction ,dbsym)
 114               ;; (format t "~&;; Transaction Abort, level ~d~%" *transaction-level*)
 115               (run-abort-hooks)
 116               (when (= 1 *transaction-level*)
 117                 (remhash  *transaction-id* *transaction-aborts*)))
 118             (when (= 1 *transaction-level*)
 119               (let ((completes (gethash *transaction-id* *transaction-completes*)))
 120                 ;; (format t "~&;; Running ~d post actions.~%" (length completes))
 121                 (mapcar #'funcall completes)
 122                 (remhash  *transaction-id* *transaction-completes*))))))))
 123