X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Ftransactions.cl;fp=sql%2Ftransactions.cl;h=6b980aa860e6638c4ebc1ee1be3ccc7faac9642d;hb=47d0d4e375f432000f780f95371cb0c32fab9712;hp=19066c233e3fae8f004a3430f79be03f95a924c2;hpb=d7ce4b7d7f6582325dfef2d5d251032c7327e3c4;p=clsql.git diff --git a/sql/transactions.cl b/sql/transactions.cl index 19066c2..6b980aa 100644 --- 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)))))