r1982: Removed the USQL transaction stuff to put a smaller, lighter one

diff --git a/sql/classes.cl b/sql/classes.cl
index c83b2008a079a87271278c35e3bcea24bd69bdcd..4cb643ac71b0230b6d07fa5d0c13ca56dd076df8 100644 (file)
--- a/sql/classes.cl
+++ b/sql/classes.cl
@@ -8,7 +8,7 @@
 ;;;;                 original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: classes.cl,v 1.5 2002/05/01 20:22:16 marc.battyani Exp $
+;;;; $Id: classes.cl,v 1.6 2002/05/07 10:19:13 marc.battyani Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -23,12 +23,12 @@
 
 
 (defclass database ()
-  ((name :initarg :name :reader database-name)
-   (connection-spec :initarg :connection-spec :reader connection-spec
+  ((name :initform nil :initarg :name :reader database-name)
+   (connection-spec :initform nil :initarg :connection-spec :reader connection-spec
                    :documentation "Require to use connection pool")
-   (transaction-level :initarg :transaction-level :accessor transaction-level)
-   (conn-pool :initarg :conn-pool :accessor conn-pool :initform nil))
-  (:default-initargs :name nil :connection-spec nil :transaction-level 0)
+   (transaction-level :initform 0 :accessor transaction-level)
+   (transaction :initform nil :accessor transaction)
+   (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool))
   (:documentation
    "This class is the supertype of all databases handled by CLSQL."))
 

diff --git a/sql/transactions.cl b/sql/transactions.cl
index 19066c233e3fae8f004a3430f79be03f95a924c2..6b980aa860e6638c4ebc1ee1be3ccc7faac9642d 100644 (file)
--- a/sql/transactions.cl
+++ b/sql/transactions.cl
@@ -4,11 +4,10 @@
 ;;;;
 ;;;; Name:          transactions.cl
 ;;;; Purpose:       Transaction support
-;;;; Programmers:   Kevin M. Rosenberg based
-;;;;                 Original code by onShore Development Inc.
+;;;; Programmers:   Kevin M. Rosenberg, Marc Battyani
 ;;;; Date Started:  Apr 2002
 ;;;;
-;;;; $Id: transactions.cl,v 1.1 2002/04/27 21:48:08 kevin Exp $
+;;;; $Id: transactions.cl,v 1.2 2002/05/07 10:19:13 marc.battyani Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 2000-2002 by onShore Development
@@ -21,103 +20,69 @@
 (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.
+;; I removed the USQL transaction stuff to put a smaller, lighter one (MB)
+
+(defclass transaction ()
+  ((commit-hooks :initform () :accessor commit-hooks)
+   (rollback-hooks :initform () :accessor rollback-hooks)
+   (aborted :initform nil :accessor aborted)))
 
 (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)
+  (unless (transaction database)
+    (setf (transaction database) (make-instance 'transaction)))
+  (when (= (incf (transaction-level database)) 1)
+    (let ((transaction (transaction database)))
+      (setf (commit-hooks transaction) nil
+           (rollback-hooks transaction) nil
+           (aborted transaction) nil)
       (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))
+(defmethod database-end-transaction ((database closed-database) commit)
   (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)
+(defmethod database-end-transaction (database commit)
+  (when (not commit)
+    (setf (aborted (transaction database)) t))
+  (if (> (transaction-level database) 0)
+    (when (zerop (decf (transaction-level database)))
+      (let ((transaction (transaction database)))
+       (if (aborted transaction)
+         (unwind-protect
+              (execute-command "ROLLBACK" :database database)
+           (map nil #'funcall (rollback-hooks database)))
+         (progn
+           (execute-command "COMMIT" :database database)
+           (map nil #'funcall (commit-hooks transaction))))))
+    (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))))
 
-(defvar *transaction-aborts* (make-hash-table))
-(defvar *transaction-completes* (make-hash-table))
+(defun abort-transaction (database)
+  (when (transaction database)
+    (setf (aborted (transaction database)) t)))
 
-(defun on-txn-abort (fn)
-  (push (cons *transaction-level* fn) (gethash *transaction-id* *transaction-aborts*)))
+(defun add-transaction-commit-hook (database abort-hook)
+  (when (transaction database)
+    (push abort-hook (abort-hooks (transaction database)))))
 
-(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 add-transaction-rollback-hook (database rollback-hook)
+  (when (transaction database)
+    (push rollback-hook (rollback-hooks (transaction database)))))
 
-(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)
+(defmacro with-transaction ((&key (database '*default-database*) abort-function)
                            &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*)))
+  (let ((db (gensym "db"))
+       (commit (gensym "commit-")))
+    `(let ((,db ,database)
+          (,commit nil))
       (unwind-protect
         (progn
-          (database-start-transaction ,dbsym)
-          (setf ,transym t)
+          (database-start-transaction ,db)
+          (setf ,commit 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*))))))))
-
+          (setf ,commit nil))
+       (database-end-transaction ,db ,commit)))))