/usr/share/common-lisp/source/clsql/sql/transaction.lisp is in cl-sql 6.7.0-1.1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
;;;; Transaction support
;;;;
;;;; This file is part of CLSQL.
;;;;
;;;; 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.
;;;; *************************************************************************
(in-package #:clsql-sys)
(defclass transaction ()
((commit-hooks :initform () :accessor commit-hooks)
(rollback-hooks :initform () :accessor rollback-hooks)
(previous-autocommit :initarg :previous-autocommit
:reader previous-autocommit)
(status :initform nil :accessor transaction-status
:documentation "nil or :committed")))
(defun add-transaction-commit-hook (commit-hook &key
(database *default-database*))
"Adds COMMIT-HOOK, which should a designator for a function
with no required arguments, to the list of hooks run when COMMIT
is called on DATABASE which defaults to *DEFAULT-DATABASE*."
(when (transaction database)
(push commit-hook (commit-hooks (transaction database)))))
(defun add-transaction-rollback-hook (rollback-hook
&key (database *default-database*))
"Adds ROLLBACK-HOOK, which should a designator for a function
with no required arguments, to the list of hooks run when ROLLBACK
is called on DATABASE which defaults to *DEFAULT-DATABASE*."
(when (transaction database)
(push rollback-hook (rollback-hooks (transaction database)))))
(defmethod database-start-transaction ((database database))
(unless (transaction database)
(setf (transaction database)
(make-instance 'transaction :previous-autocommit
(database-autocommit database))))
;; TODO: database-autocommit might get lost in some scenarios
;; when pooling connections
(setf (database-autocommit database) nil)
(when (= (incf (transaction-level database)) 1)
(let ((transaction (transaction database)))
(setf (commit-hooks transaction) nil
(rollback-hooks transaction) nil
(transaction-status transaction) nil)
(case (database-underlying-type database)
(:oracle nil)
(:mssql (execute-command "BEGIN TRANSACTION" :database database))
(t (execute-command "BEGIN" :database database))))))
;;ODBC should potentially be using the following scheme for transactions:
;; turn off autocommit for begin. then use sqlendtran (or maybe sqltransact)
;; whatever is appropriate for this version of odbc.
(defmethod database-commit-transaction ((database database))
(with-slots (transaction transaction-level autocommit) database
(if (plusp transaction-level)
(if (zerop (decf transaction-level))
(progn
(case (database-underlying-type database)
(:mssql (execute-command "COMMIT TRANSACTION" :database database))
(t (execute-command "COMMIT" :database database)))
(setf autocommit (previous-autocommit transaction))
(map nil #'funcall (commit-hooks transaction)))
(setf (transaction-status (transaction database)) nil))
(warn 'sql-warning
:message
(format nil "Cannot commit transaction against ~A because there is no transaction in progress."
database)))))
(defmethod database-abort-transaction ((database database))
(with-slots (transaction transaction-level autocommit) database
(if (plusp transaction-level)
(when (zerop (decf transaction-level))
(unwind-protect
(case (database-underlying-type database)
(:mssql (execute-command "ROLLBACK TRANSACTION" :database database))
(t (execute-command "ROLLBACK" :database database)))
(setf autocommit (previous-autocommit transaction))
(map nil #'funcall (rollback-hooks transaction))))
(warn 'sql-warning
:message
(format nil "Cannot abort transaction against ~A because there is no transaction in progress."
database)))))
(defun mark-transaction-committed (database)
(when (and (transaction database)
(not (transaction-status (transaction database))))
(setf (transaction-status (transaction database)) :committed)))
(defmacro with-transaction ((&key (database '*default-database*)) &body body)
"Starts a transaction in the database specified by DATABASE,
which is *DEFAULT-DATABASE* by default, and executes BODY within
that transaction. If BODY aborts or throws, DATABASE is rolled
back and otherwise the transaction is committed."
(let ((db (gensym "db-")))
`(let ((,db ,database))
(unwind-protect
(prog2
(database-start-transaction ,db)
(progn
,@body)
(mark-transaction-committed ,db))
(if (eq (transaction-status (transaction ,db)) :committed)
(database-commit-transaction ,db)
(database-abort-transaction ,db))))))
(defun commit (&key (database *default-database*))
"If DATABASE, which defaults to *DEFAULT-DATABASE*, is
currently within the scope of a transaction, commits changes made
since the transaction began."
(database-commit-transaction database)
nil)
(defun rollback (&key (database *default-database*))
"If DATABASE, which defaults to *DEFAULT-DATABASE*, is
currently within the scope of a transaction, rolls back changes
made since the transaction began."
(database-abort-transaction database)
nil)
(defun start-transaction (&key (database *default-database*))
"Starts a transaction block on DATABASE which defaults to
*DEFAULT-DATABASE* and which continues until ROLLBACK or COMMIT
are called."
(unless (in-transaction-p :database database)
(database-start-transaction database))
nil)
(defun in-transaction-p (&key (database *default-database*))
"A predicate to test whether DATABASE, which defaults to
*DEFAULT-DATABASE*, is currently within the scope of a
transaction."
(and database (transaction database) (= (transaction-level database) 1)))
(defun set-autocommit (value &key (database *default-database*))
"Turns autocommit off for DATABASE if VALUE is NIL, and
otherwise turns it on. Returns the old value of autocommit flag.
For RDBMS (such as Oracle) which don't automatically commit
changes, turning autocommit on has the effect of explicitly
committing changes made whenever SQL statements are executed.
Autocommit is turned on by default."
(let ((old-value (database-autocommit database)))
(setf (database-autocommit database) value)
(database-autocommit database)
old-value))
|