X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Ftransactions.cl;h=c95e8c307501fd368049b48623af48401658b242;hp=19066c233e3fae8f004a3430f79be03f95a924c2;hb=998937376fa6f9ce29bd3c7954fb0ebca91c37d7;hpb=d302d2db4f7ff7a31bce893e31aecbc2a84a162f diff --git a/sql/transactions.cl b/sql/transactions.cl index 19066c2..c95e8c3 100644 --- a/sql/transactions.cl +++ b/sql/transactions.cl @@ -4,14 +4,12 @@ ;;;; ;;;; Name: transactions.cl ;;;; Purpose: Transaction support -;;;; Programmers: Kevin M. Rosenberg based -;;;; Original code by onShore Development Inc. +;;;; Programmers: 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.7 2002/09/17 17:16:43 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 @@ -21,103 +19,67 @@ (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) + (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited (defmethod database-start-transaction ((database closed-database)) - (signal-closed-database-error database)) + (error 'clsql-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 + (status 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)) - (signal-closed-database-error database)) +(defmethod database-end-transaction ((database closed-database)) + (error 'clsql-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))))) +(defmethod database-end-transaction (database) + (if (> (transaction-level database) 0) + (when (zerop (decf (transaction-level database))) + (let ((transaction (transaction database))) + (if (eq (status transaction) :commited) + (progn + (execute-command "COMMIT" :database database) + (map nil #'funcall (commit-hooks transaction))) + (unwind-protect ;status is not :commited + (execute-command "ROLLBACK" :database database) + (map nil #'funcall (rollback-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-level* 0) -(defvar *transaction-id* nil) +(defun rollback-transaction (database) + (when (and (transaction database)(not (status (transaction database)))) + (setf (status (transaction database)) :rolled-back))) -(defvar *transaction-aborts* (make-hash-table)) -(defvar *transaction-completes* (make-hash-table)) +(defun commit-transaction (database) + (when (and (transaction database)(not (status (transaction database)))) + (setf (status (transaction database)) :commited))) -(defun on-txn-abort (fn) - (push (cons *transaction-level* fn) (gethash *transaction-id* *transaction-aborts*))) +(defun add-transaction-commit-hook (database commit-hook) + (when (transaction database) + (push commit-hook (commit-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) - &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*))) +(defmacro with-transaction ((&key (database '*default-database*)) &rest body) + (let ((db (gensym "db-"))) + `(let ((,db ,database)) (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*)))))))) - + (progn + (database-start-transaction ,db) + ,@body + (commit-transaction ,db)) + (database-end-transaction ,db)))))