From: Kevin M. Rosenberg Date: Sat, 27 Apr 2002 21:48:08 +0000 (+0000) Subject: r1801: Added transaction code X-Git-Tag: v3.8.6~1137 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=d302d2db4f7ff7a31bce893e31aecbc2a84a162f r1801: Added transaction code --- diff --git a/ChangeLog b/ChangeLog index 514d644..fb92c48 100644 --- 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 82e6d53..9cc76b7 100644 --- 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 ea2b12e..59a23b4 100644 --- a/interfaces/mysql/mysql-usql.cl +++ b/interfaces/mysql/mysql-usql.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: mysql-usql.cl,v 1.4 2002/04/27 21:12:32 kevin Exp $ +;;;; $Id: mysql-usql.cl,v 1.5 2002/04/27 21:48:08 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and by onShore Development Inc. @@ -78,20 +78,6 @@ database) (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) -;; Transactions - -(defmethod database-start-transaction ((database mysql-database)) - "Start a transaction in DATABASE." - (database-execute-command "BEGIN" database)) - -(defmethod database-commit-transaction ((database mysql-database)) - "Commit current transaction in DATABASE." - (database-execute-command "COMMIT" database)) - -(defmethod database-abort-transaction ((database mysql-database)) - "Abort current transaction in DATABASE." - (database-execute-command "ROLLBACK" database)) - ;; Misc USQL functions #+ignore diff --git a/sql/classes.cl b/sql/classes.cl index 7a3f336..72e44c7 100644 --- 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 @@ "") 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 3624819..e5097ae 100644 --- 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 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*)))))))) +