r1989: Moddified transactions

diff --git a/ChangeLog b/ChangeLog
index 99cf1dd50820b437412964a6c6bf7710903d1cfe..3da17ea67064a72fdfc148f21ac027b7f2e68810 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+10 May 2002 Marc Battyani (marc.battyani@fractalconcept.com)
+       * sql/classes.cl:
+       * sql/transactions.cl:
+       Added transaction support. Functions/macros added:
+       with-transaction, commit-transaction, rollback-transaction,
+       add-transaction-commit-hook, add-transaction-rollback-hook
+
 04 May 2002 Marc Battyani (marc.battyani@fractalconcept.com)
        * sql/sql.cl:
        * sql/pool.cl:

diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl
index 809507c2e341e04752671612bc9faf432d962da5..7e9d6e89a4051d5bedf0f8ea86ba4443707d2c9b 100644 (file)
--- a/interfaces/postgresql/postgresql-sql.cl
+++ b/interfaces/postgresql/postgresql-sql.cl
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: postgresql-sql.cl,v 1.15 2002/04/27 20:58:11 kevin Exp $
+;;;; $Id: postgresql-sql.cl,v 1.16 2002/05/10 08:05:48 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
@@ -285,23 +285,22 @@
   (lo-create (database-conn-ptr database)
             (logior postgresql::+INV_WRITE+ postgresql::+INV_READ+)))
 
-;; (MB)the begin/commit/rollback stuff will be removed when with-transaction wil be implemented
-(defmethod database-write-large-object ( object-id (data string) (database postgresql-database))
+(defmethod database-write-large-object (object-id (data string) (database postgresql-database))
   (let ((ptr (database-conn-ptr database))
        (length (length data))
        (result nil)
        (fd nil))
-    (unwind-protect
-       (progn 
-        (database-execute-command "begin" database)
-        (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+))
-        (when (>= fd 0)
-          (when (= (lo-write ptr fd data length) length)
-            (setf result t))))
-      (progn
-       (when (and fd (>= fd 0))
-         (lo-close ptr fd))
-       (database-execute-command (if result "commit" "rollback") database)))
+    (with-transaction (:database database)
+       (unwind-protect
+         (progn 
+           (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+))
+           (when (>= fd 0)
+             (when (= (lo-write ptr fd data length) length)
+               (setf result t))))
+        (progn
+          (when (and fd (>= fd 0))
+            (lo-close ptr fd))
+          )))
     result))
 
 ;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented

diff --git a/sql/package.cl b/sql/package.cl
index 48e454230d83bdbf23b9b3d4928a3438cc877d62..f811926a9375a34a7d916d5acf5544500e29ae6c 100644 (file)
--- a/sql/package.cl
+++ b/sql/package.cl
@@ -1 +1 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r;;;; *************************************************************************\r;;;; FILE IDENTIFICATION\r;;;;\r;;;; Name:          package.cl\r;;;; Purpose:       Package definition for high-level SQL interface\r;;;; Programmers:   Kevin M. Rosenberg based on\r;;;;                Original code by Pierre R. Mai \r;;;; Date Started:  Feb 2002\r;;;;\r;;;; $Id: package.cl,v 1.12 2002/05/08 16:56:54 marc.battyani Exp $\r;;;;\r;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r;;;; and Copyright (c) 1999-2001 by Pierre R. Mai\r;;;;\r;;;; CLSQL users are granted the rights to distribute and use this software\r;;;; as governed by the terms of the Lisp Lesser GNU Public License\r;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r;;;; *************************************************************************\r\r(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r(in-package :cl-user)\r\r;;;; This file makes the required package definitions for CLSQL's\r;;;; core packages.\r;;;; \r\r(eval-when (:compile-toplevel :load-toplevel :execute)\r(defpackage :clsql-sys\r  (:use :common-lisp)\r  (:export\r     ;; "Private" exports for use by interface packages\r     #:check-connection-spec\r     #:database-type-load-foreign\r     #:database-type-library-loaded ;; KMR - Tests if foreign library okay\r     #:database-initialize-database-type\r     #:database-connect\r     #:database-disconnect\r     #:database-query\r     #:database-execute-command\r     #:database-query-result-set\r     #:database-dump-result-set\r     #:database-store-next-row\r     \r     ;; For UncommonSQL support\r     #:database-list-tables\r     #:database-list-attributes\r     #:database-attribute-type\r     #:database-create-sequence \r     #:database-drop-sequence\r     #:database-sequence-next\r     #:sql-escape\r\r     ;; Support for pooled connections\r     #:database-type\r\r     ;; Large objects (Marc B)\r     #:database-create-large-object\r     #:database-write-large-object\r     #:database-read-large-object\r     #:database-delete-large-object\r     \r     ;; Shared exports for re-export by CLSQL\r\r     .\r     #1=(#:clsql-condition\r      #:clsql-error\r  #:clsql-simple-error\r   #:clsql-warning\r        #:clsql-simple-warning\r         #:clsql-invalid-spec-error\r     #:clsql-invalid-spec-error-connection-spec\r     #:clsql-invalid-spec-error-database-type\r       #:clsql-invalid-spec-error-template\r    #:clsql-connect-error\r  #:clsql-connect-error-database-type\r    #:clsql-connect-error-connection-spec\r  #:clsql-connect-error-errno\r    #:clsql-connect-error-error\r    #:clsql-sql-error\r      #:clsql-sql-error-database\r     #:clsql-sql-error-expression\r   #:clsql-sql-error-errno\r        #:clsql-sql-error-error\r        #:clsql-database-warning\r       #:clsql-database-warning-database\r      #:clsql-database-warning-message\r       #:clsql-exists-condition\r       #:clsql-exists-condition-new-db\r        #:clsql-exists-condition-old-db\r        #:clsql-exists-warning\r         #:clsql-exists-error\r   #:clsql-closed-error\r   #:clsql-closed-error-database\r  #:*loaded-database-types*\r      #:reload-database-types\r        #:*default-database-type*\r      #:*initialized-database-types*\r         #:initialize-database-type\r     #:*connect-if-exists*\r  #:*default-database*\r   #:connected-databases\r  #:database\r     #:database-name\r        #:closed-database\r      #:find-database\r        #:database-name-from-spec\r      #:connect\r      #:disconnect\r   #:query\r        #:execute-command\r      #:map-query\r    #:do-query\r\r    ;; functional.cl\r       #:insert-records\r       #:delete-records\r       #:update-records\r       #:with-database\r        \r       ;; utils.cl\r    #:number-to-sql-string\r         #:float-to-sql-string\r  #:sql-escape-quotes\r\r   ;; For UncommonSQL support\r     #:sql-ident\r    #:list-tables\r  #:list-attributes\r      #:attribute-type\r       #:create-sequence \r     #:drop-sequence\r        #:sequence-next\r        #:transaction-start\r    #:transaction-commit\r   #:transaction-abort\r\r   ;; Pooled connections\r  #:disconnect-pooled\r    \r       ;; Transactions\r        #:with-transaction\r\r    ;; Large objects (Marc B)\r      #:create-large-object\r  #:write-large-object\r   #:read-large-object\r    #:delete-large-object\r  ))\r    (:documentation "This is the INTERNAL SQL-Interface package of CLSQL."))\r\r(defpackage #:clsql\r    (:import-from #:clsql-sys . #1#)\r    (:export . #1#)\r    (:documentation "This is the SQL-Interface package of CLSQL."))\r);eval-when\r\r(defpackage #:clsql-user\r    (:use #:common-lisp #:clsql)\r    (:documentation "This is the user package for experimenting with CLSQL."))\r
\ No newline at end of file
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r;;;; *************************************************************************\r;;;; FILE IDENTIFICATION\r;;;;\r;;;; Name:          package.cl\r;;;; Purpose:       Package definition for high-level SQL interface\r;;;; Programmers:   Kevin M. Rosenberg based on\r;;;;                Original code by Pierre R. Mai \r;;;; Date Started:  Feb 2002\r;;;;\r;;;; $Id: package.cl,v 1.13 2002/05/10 08:05:48 marc.battyani Exp $\r;;;;\r;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg\r;;;; and Copyright (c) 1999-2001 by Pierre R. Mai\r;;;;\r;;;; CLSQL users are granted the rights to distribute and use this software\r;;;; as governed by the terms of the Lisp Lesser GNU Public License\r;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r;;;; *************************************************************************\r\r(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))\r(in-package :cl-user)\r\r;;;; This file makes the required package definitions for CLSQL's\r;;;; core packages.\r;;;; \r\r(eval-when (:compile-toplevel :load-toplevel :execute)\r(defpackage :clsql-sys\r  (:use :common-lisp)\r  (:export\r     ;; "Private" exports for use by interface packages\r     #:check-connection-spec\r     #:database-type-load-foreign\r     #:database-type-library-loaded ;; KMR - Tests if foreign library okay\r     #:database-initialize-database-type\r     #:database-connect\r     #:database-disconnect\r     #:database-query\r     #:database-execute-command\r     #:database-query-result-set\r     #:database-dump-result-set\r     #:database-store-next-row\r     \r     ;; For UncommonSQL support\r     #:database-list-tables\r     #:database-list-attributes\r     #:database-attribute-type\r     #:database-create-sequence \r     #:database-drop-sequence\r     #:database-sequence-next\r     #:sql-escape\r\r     ;; Support for pooled connections\r     #:database-type\r\r     ;; Large objects (Marc B)\r     #:database-create-large-object\r     #:database-write-large-object\r     #:database-read-large-object\r     #:database-delete-large-object\r     \r     ;; Shared exports for re-export by CLSQL\r\r     .\r     #1=(#:clsql-condition\r      #:clsql-error\r  #:clsql-simple-error\r   #:clsql-warning\r        #:clsql-simple-warning\r         #:clsql-invalid-spec-error\r     #:clsql-invalid-spec-error-connection-spec\r     #:clsql-invalid-spec-error-database-type\r       #:clsql-invalid-spec-error-template\r    #:clsql-connect-error\r  #:clsql-connect-error-database-type\r    #:clsql-connect-error-connection-spec\r  #:clsql-connect-error-errno\r    #:clsql-connect-error-error\r    #:clsql-sql-error\r      #:clsql-sql-error-database\r     #:clsql-sql-error-expression\r   #:clsql-sql-error-errno\r        #:clsql-sql-error-error\r        #:clsql-database-warning\r       #:clsql-database-warning-database\r      #:clsql-database-warning-message\r       #:clsql-exists-condition\r       #:clsql-exists-condition-new-db\r        #:clsql-exists-condition-old-db\r        #:clsql-exists-warning\r         #:clsql-exists-error\r   #:clsql-closed-error\r   #:clsql-closed-error-database\r  #:*loaded-database-types*\r      #:reload-database-types\r        #:*default-database-type*\r      #:*initialized-database-types*\r         #:initialize-database-type\r     #:*connect-if-exists*\r  #:*default-database*\r   #:connected-databases\r  #:database\r     #:database-name\r        #:closed-database\r      #:find-database\r        #:database-name-from-spec\r      #:connect\r      #:disconnect\r   #:query\r        #:execute-command\r      #:map-query\r    #:do-query\r\r    ;; functional.cl\r       #:insert-records\r       #:delete-records\r       #:update-records\r       #:with-database\r        \r       ;; utils.cl\r    #:number-to-sql-string\r         #:float-to-sql-string\r  #:sql-escape-quotes\r\r   ;; For UncommonSQL support\r     #:sql-ident\r    #:list-tables\r  #:list-attributes\r      #:attribute-type\r       #:create-sequence \r     #:drop-sequence\r        #:sequence-next\r\r       ;; Pooled connections\r  #:disconnect-pooled\r\r   ;; Transactions\r        #:with-transaction\r     #:commit-transaction\r   #:rollback-transaction\r         #:add-transaction-commit-hook\r  #:add-transaction-rollback-hook\r\r       ;; Large objects (Marc B)\r      #:create-large-object\r  #:write-large-object\r   #:read-large-object\r    #:delete-large-object\r  ))\r    (:documentation "This is the INTERNAL SQL-Interface package of CLSQL."))\r\r(defpackage #:clsql\r    (:import-from #:clsql-sys . #1#)\r    (:export . #1#)\r    (:documentation "This is the SQL-Interface package of CLSQL."))\r);eval-when\r\r(defpackage #:clsql-user\r    (:use #:common-lisp #:clsql)\r    (:documentation "This is the user package for experimenting with CLSQL."))\r
\ No newline at end of file

diff --git a/sql/transactions.cl b/sql/transactions.cl
index 6b980aa860e6638c4ebc1ee1be3ccc7faac9642d..7717162d604cbf833b427dd50903dfbb2a5ac782 100644 (file)
--- a/sql/transactions.cl
+++ b/sql/transactions.cl
@@ -4,13 +4,12 @@
 ;;;;
 ;;;; Name:          transactions.cl
 ;;;; Purpose:       Transaction support
-;;;; Programmers:   Kevin M. Rosenberg, Marc Battyani
+;;;; Programmers:   Marc Battyani
 ;;;; Date Started:  Apr 2002
 ;;;;
-;;;; $Id: transactions.cl,v 1.2 2002/05/07 10:19:13 marc.battyani Exp $
+;;;; $Id: transactions.cl,v 1.3 2002/05/10 08:05:48 marc.battyani 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
@@ -25,7 +24,7 @@
 (defclass transaction ()
   ((commit-hooks :initform () :accessor commit-hooks)
    (rollback-hooks :initform () :accessor rollback-hooks)
-   (aborted :initform nil :accessor aborted)))
+   (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited
 
 (defmethod database-start-transaction ((database closed-database))
   (signal-closed-database-error database))
@@ -37,33 +36,35 @@
     (let ((transaction (transaction database)))
       (setf (commit-hooks transaction) nil
            (rollback-hooks transaction) nil
-           (aborted transaction) nil)
+           (status transaction) nil)
       (execute-command "BEGIN" :database database))))
 
-(defmethod database-end-transaction ((database closed-database) commit)
+(defmethod database-end-transaction ((database closed-database))
   (signal-closed-database-error database))
 
-(defmethod database-end-transaction (database commit)
-  (when (not commit)
-    (setf (aborted (transaction database)) t))
+(defmethod database-end-transaction (database)
   (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)))
+       (if (eq (status transaction) :commited)
          (progn
            (execute-command "COMMIT" :database database)
-           (map nil #'funcall (commit-hooks transaction))))))
+           (map nil #'funcall (commit-hooks transaction)))
+         (unwind-protect ;status is not :commited
+              (execute-command "ROLLBACK" :database database)
+           (map nil #'funcall (rollback-hooks 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))))
 
-(defun abort-transaction (database)
-  (when (transaction database)
-    (setf (aborted (transaction database)) t)))
+(defun rollback-transaction (database)
+  (when (and (transaction database)(not (status (transaction database))))
+    (setf (status (transaction database)) :rolled-back)))
+
+(defun commit-transaction (database)
+  (when (and (transaction database)(not (status (transaction database))))
+    (setf (status (transaction database)) :commited)))
 
 (defun add-transaction-commit-hook (database abort-hook)
   (when (transaction database)
@@ -73,16 +74,12 @@
   (when (transaction database)
     (push rollback-hook (rollback-hooks (transaction database)))))
 
-(defmacro with-transaction ((&key (database '*default-database*) abort-function)
-                           &rest body)
-  (let ((db (gensym "db"))
-       (commit (gensym "commit-")))
-    `(let ((,db ,database)
-          (,commit nil))
+(defmacro with-transaction ((&key (database '*default-database*)) &rest body)
+  (let ((db (gensym "db-")))
+    `(let ((,db ,database))
       (unwind-protect
-        (progn
-          (database-start-transaction ,db)
-          (setf ,commit t)
-          ,@body
-          (setf ,commit nil))
-       (database-end-transaction ,db ,commit)))))
+          (progn
+            (start-transaction ,db)
+            ,@body
+            (commit-transaction ,db))
+       (database-end-transaction ,db)))))