r1801: Added transaction code

diff --git a/ChangeLog b/ChangeLog
index 514d64412116d02b69bb6818b7955133dbccdb9c..fb92c48726c8c9ba991fd99b4f5f8e5426204444 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,10 @@
 27 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net)
        * Multiple files:
        Added initial support for connection pool
-       Added transactions for MySQL
+       * sql/transactions.cl
+       Took transaction code from UncommonSQL and integrated
+       into CLSQL code. See file for disclaimer about why this
+       was added.
 
 23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net)
        * interfaces/postgresql/postgresql-sql.cl:

diff --git a/clsql.system b/clsql.system
index 82e6d53eac446625ecf936f8555a36c38c01c940..9cc76b7c28786401880e1b8e7f097591ce4429be 100644 (file)
--- a/clsql.system
+++ b/clsql.system
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: clsql.system,v 1.6 2002/04/27 20:58:11 kevin Exp $
+;;;; $Id: clsql.system,v 1.7 2002/04/27 21:48:08 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -42,6 +42,7 @@
                 (:file "db-interface" :depends-on ("conditions"))
                 (:file "pool" :depends-on ("db-interface"))
                 (:file "sql" :depends-on ("pool"))
+                (:file "transactions" :depends-on ("sql"))
                 (:file "utils" :depends-on ("package"))
                 (:file "functional" :depends-on ("sql"))
                 (:file "usql" :depends-on ("sql")))

diff --git a/interfaces/mysql/mysql-usql.cl b/interfaces/mysql/mysql-usql.cl
index ea2b12ea104bd9a0d4d591f06fdb32c81aa77dc1..59a23b44f2a46e8bcd4e14bfe03dff71ea876242 100644 (file)
--- a/interfaces/mysql/mysql-usql.cl
+++ b/interfaces/mysql/mysql-usql.cl
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg and onShore Development Inc\r
 ;;;; Date Started:  Mar 2002\r
 ;;;;\r
-;;;; $Id: mysql-usql.cl,v 1.4 2002/04/27 21:12:32 kevin Exp $\r
+;;;; $Id: mysql-usql.cl,v 1.5 2002/04/27 21:48:08 kevin Exp $\r
 ;;;;\r
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r
 ;;;; and by onShore Development Inc.\r
@@ -78,20 +78,6 @@
    database)\r
   (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))\r
 \r
-;; Transactions\r
-\r
-(defmethod database-start-transaction ((database mysql-database))\r
- "Start a transaction in DATABASE."\r
- (database-execute-command "BEGIN" database))\r
-\r
-(defmethod database-commit-transaction ((database mysql-database))\r
-  "Commit current transaction in DATABASE."\r
-  (database-execute-command "COMMIT" database))\r
-\r
-(defmethod database-abort-transaction ((database mysql-database))\r
-  "Abort current transaction in DATABASE."\r
-  (database-execute-command "ROLLBACK" database))\r
-\r
 ;; Misc USQL functions\r
 \r
 #+ignore\r

diff --git a/sql/classes.cl b/sql/classes.cl
index 7a3f336a7cc6a61237b37a487e21350e4135341f..72e44c7dcb9a6e139d015f0fbea42127836ae8a8 100644 (file)
--- a/sql/classes.cl
+++ b/sql/classes.cl
@@ -5,10 +5,10 @@
 ;;;; Name:          classes.cl
 ;;;; Purpose:       Classes for High-level SQL interface
 ;;;; Programmers:   Kevin M. Rosenberg based on
-;;;;                 Original code by Pierre R. Mai 
+;;;;                 original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: classes.cl,v 1.2 2002/04/27 20:58:11 kevin Exp $
+;;;; $Id: classes.cl,v 1.3 2002/04/27 21:48:08 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -25,7 +25,9 @@
 (defclass database ()
   ((name :initarg :name :reader database-name)
    (connection-spec :initarg :connection-spec :reader connection-spec
-                   :documentation "Require to use connection pool"))
+                   :documentation "Require to use connection pool")
+   (transaction-level :accessor transaction-level))
+  (:default-initargs :name nil :connection-spec nil :transaction-level 0)
   (:documentation
    "This class is the supertype of all databases handled by CLSQL."))
 
@@ -36,12 +38,12 @@
                      "<unbound>")
                  stream)))
 
+;; Closed database idea and original code comes from UncommonSQL
 
 (defclass closed-database ()
   ((name :initarg :name :reader database-name))
   (:documentation
-   "This class represents all databases after they are closed via
-`disconnect'."))
+   "This class represents databases after they are closed via 'disconnect'."))
 
 (defmethod print-object ((object closed-database) stream)
   (print-unreadable-object (object stream :type t :identity t)

diff --git a/sql/package.cl b/sql/package.cl
index 36248198843712962e1248231720c290a8724eb7..e5097aec19a71e0b209adb104858bd2ba2e30ffe 100644 (file)
--- a/sql/package.cl
+++ b/sql/package.cl
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: package.cl,v 1.8 2002/04/27 20:58:11 kevin Exp $
+;;;; $Id: package.cl,v 1.9 2002/04/27 21:48:08 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -58,9 +58,6 @@
      #:database-read-large-object
      #:database-delete-large-object
      
-     ;; Pooled connections
-     #:disconnect-pooled
-     
      ;; Shared exports for re-export by CLSQL
      .
      #1=(#:clsql-condition
@@ -132,7 +129,16 @@
         #:create-sequence 
         #:drop-sequence
         #:sequence-next
+        #:transaction-start
+        #:transaction-commit
+        #:transaction-abort
         
+        ;; Pooled connections
+        #:disconnect-pooled
+
+        ;; Transactions
+        #:with-transaction
+
         ;; Large objects (Marc B)
         #:create-large-object
         #:write-large-object

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*))))))))
+