r1801: Added transaction code

[clsql.git] / sql / transactions.cl

diff --git a/sql/transactions.cl b/sql/transactions.cl
new file mode 100644 (file)
index 0000000..19066c2
--- /dev/null
+++ b/sql/transactions.cl
@@ -0,0 +1,123 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          transactions.cl
+;;;; Purpose:       Transaction support
+;;;; Programmers:   Kevin M. Rosenberg based
+;;;;                 Original code by onShore Development Inc.
+;;;; Date Started:  Apr 2002
+;;;;
+;;;; $Id: transactions.cl,v 1.1 2002/04/27 21:48:08 kevin Exp $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; and Copyright (c) 2000-2002 by onShore Development
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :clsql-sys)
+
+;; This code is copied verbatim from UncommonSQL. It is intended to
+;; provide transaction support to CLSQL users that, for whatever reason, 
+;; don't want to use the upcoming UncommonSQL/CLSQL combination.
+
+(defmethod database-start-transaction ((database closed-database))
+  (signal-closed-database-error database))
+
+(defmethod database-start-transaction (database)
+  (unless database
+    (error 'clsql-nodb-error))
+  (with-accessors ((level transaction-level))
+    database
+    (incf level)
+    (when (= level 1)
+      (execute-command "BEGIN" :database database))))
+
+(defmethod database-commit-transaction ((database closed-database))
+  (signal-closed-database-error database))
+
+(defmethod database-commit-transaction (database)
+  (with-accessors ((level transaction-level))
+    database
+    (if (< 0 level)
+        (progn
+          (decf level)
+          (when (= level 0)
+            (execute-command "COMMIT" :database database)))
+      (warn "Continue without commit."
+           'clsql-simple-error
+           :format-control "Cannot commit transaction against ~A because there is no transaction in progress."
+           :format-arguments (list database)))))
+
+(defmethod database-abort-transaction ((database closed-database))
+  (signal-closed-database-error database))
+
+(defmethod database-abort-transaction (database)
+  (with-accessors ((level transaction-level))
+    database
+  (if (< 0 level)
+      (progn
+        (setf level 0)
+        (execute-command "ROLLBACK" :database database))
+      (warn "Continue without abort."
+              'clsql-simple-error
+              :format-control "Cannot abort transaction against ~A because there is no transaction in progress."
+              :format-arguments (list database)))))
+
+(defvar *transaction-level* 0)
+(defvar *transaction-id* nil)
+
+(defvar *transaction-aborts* (make-hash-table))
+(defvar *transaction-completes* (make-hash-table))
+
+(defun on-txn-abort (fn)
+  (push (cons *transaction-level* fn) (gethash *transaction-id* *transaction-aborts*)))
+
+(defun on-txn-complete (fn)
+  (if (> *transaction-level* 0)
+      (push fn (gethash *transaction-id* *transaction-completes*))
+      (warn "Cannot define on-txn-complete actions outside of transactions.")))
+
+(defun run-abort-hooks ()
+  (let ((remainder (remove-if (lambda (hook)
+                                (< (car hook) *transaction-level*))
+                              (gethash *transaction-id* *transaction-aborts*))))
+    (mapcar #'(lambda (hook)
+                (funcall (cdr hook)))
+            (gethash *transaction-id* *transaction-aborts*))
+    (setf (gethash *transaction-id* *transaction-aborts*) remainder)))
+    
+
+(defmacro with-transaction ((&key database)
+                           &rest body)
+  (let ((dbsym (gensym "db"))
+       (transym (gensym "tran")))
+    `(let ((,dbsym (or ,database *default-database*))
+          (,transym nil)
+           (*transaction-id* (or *transaction-id*
+                                 (gensym "txn")))
+           (*transaction-level* (1+ *transaction-level*)))
+      (unwind-protect
+        (progn
+          (database-start-transaction ,dbsym)
+          (setf ,transym t)
+          ,@body
+          (database-commit-transaction ,dbsym)
+          (setf ,transym nil))
+        (if ,transym
+            (progn                      ; was aborted
+              (database-abort-transaction ,dbsym)
+              ;; (format t "~&;; Transaction Abort, level ~d~%" *transaction-level*)
+              (run-abort-hooks)
+              (when (= 1 *transaction-level*)
+                (remhash  *transaction-id* *transaction-aborts*)))
+            (when (= 1 *transaction-level*)
+              (let ((completes (gethash *transaction-id* *transaction-completes*)))
+                ;; (format t "~&;; Running ~d post actions.~%" (length completes))
+                (mapcar #'funcall completes)
+                (remhash  *transaction-id* *transaction-completes*))))))))
+