Merge branch 'connection-pool-fix'
authorNathan Bird <nathan@acceleration.net>
Tue, 2 Mar 2010 23:19:02 +0000 (18:19 -0500)
committerNathan Bird <nathan@acceleration.net>
Tue, 2 Mar 2010 23:19:02 +0000 (18:19 -0500)
13 files changed:
ChangeLog
TODO
doc/Makefile
doc/README [new file with mode: 0644]
doc/csql.xml
doc/ref-ooddl.xml
doc/ref-syntax.xml
sql/database.lisp
sql/db-interface.lisp
sql/oodml.lisp
sql/package.lisp
sql/pool.lisp
sql/syntax.lisp

index 02308e95840dbc41078fb17a04a6efafae41dce1..63b51ba0caa11445743f34dbf9a3f489c8b7c23d 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2010-03-02  Nathan Bird  <nathan@acceleration.net>
+       * doc/: Added a README on how to build doc; now builds on Ubuntu.
+       * sql/oodml.lisp: READ-SQL-VALUE now has explicit method for
+       handling double-floats and the default method will no longer
+       attempt to convert values that have already been converted.
+       * sql/syntax.lisp: Introduce file-enable-sql-reader-syntax which
+       enables the syntax for the scope of the file without trying to
+       keep track of the current syntax state.
+       * sql/pool.lisp: Introduce
+       clsql-sys:*db-pool-max-free-connections* which is a heuristic
+       threshold for when to disconnect a connection rather than
+       returning it to the pool.
+       * sql/pool.lisp: Check connections for validity before returning
+       to the user.
+
 2010-03-01  Kevin Rosenberg <kevin@rosenberg.net>
        * db-mysql/mysql-api.lisp: Remove spurious enumeration
 
diff --git a/TODO b/TODO
index 4b85e96bb72fbe6c5f49732d197e16d39a48fa50..795ec6a6d6d441ee916e4cce90c06816582654d3 100644 (file)
--- a/TODO
+++ b/TODO
@@ -22,3 +22,6 @@ POSSIBLE EXTENSIONS
 
 * improve large object api and extend to databases beyond postgresql 
 * add support for prepared statements
+
+RACE CONDITIONS
+* sql/databases.lisp: *connected-databases* is shared globally but not modified in a threadsafe manner.
index 25c145281bc340843963c38fad781c0ad3c199dc..59a524b969407a1776cf1fd8b6b55ad91642db04 100644 (file)
@@ -26,6 +26,7 @@ SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*')
 REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*')
 MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*')
 DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*')
+UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*')
 
 
 ifneq (${DEBIAN},0)
@@ -45,6 +46,10 @@ else
        else   
           ifneq (${DARWIN},0)
             OS=darwin
+         else
+           ifneq (${UBUNTU},0)
+               OS:=debian
+           endif
          endif 
         endif
       endif
diff --git a/doc/README b/doc/README
new file mode 100644 (file)
index 0000000..5c0c268
--- /dev/null
@@ -0,0 +1,24 @@
+Building the documentation:
+
+You will need the following packages:
+ * xsltproc
+ * docbook
+ * docbook-xml
+ * docbook-xsl
+ * docbook-xsl-doc-html
+ * fop
+
+These are the debian/ubuntu package names; on other systems there are probably similar.
+
+
+General Build:
+> make
+
+Check the validity of the source
+> make check
+
+Build just the html:
+> make html
+
+Build just the pdf:
+> make pdf
index 4787898bb3996ec6157698b6604218fb9a0d8c5b..f4944410282822326b347c3652938d440c5f78ab 100644 (file)
@@ -465,24 +465,24 @@ There are other :join-info options available in &clsql;, but we will
 save those till we get to the many-to-many relation examples.
 </para>
 
-
-    <title>Object Oriented Class Relations</title>
-
-<para>
-&clsql; provides an Object Oriented Data Definition Language, which
-provides a mapping from &sql; tables to CLOS objects. By default class
-inheritance is handled by including all the columns from parent
-classes into the child class. This means your database schema becomes
-very much denormalized. The class option <symbol>:normalizedp</symbol>
-can be used to disable the default behaviour and have &clsql;
-normalize the database schemas of inherited classes.
-</para>
-
-<para>
-See <link linkend="def-view-class"><function>def-view-class</function></link>
-for more information.
-</para>
-
+<simplesect>
+  <title>Object Oriented Class Relations</title>
+
+  <para>
+    &clsql; provides an Object Oriented Data Definition Language, which
+    provides a mapping from &sql; tables to CLOS objects. By default class
+    inheritance is handled by including all the columns from parent
+    classes into the child class. This means your database schema becomes
+    very much denormalized. The class option <symbol>:normalizedp</symbol>
+    can be used to disable the default behaviour and have &clsql;
+    normalize the database schemas of inherited classes.
+  </para>
+  
+  <para>
+    See <link linkend="def-view-class"><function>def-view-class</function></link>
+    for more information.
+  </para>
+</simplesect>
 </sect1>
 
 <sect1 id="csql-creat">
index de79f21229028207fef7aaf801129de7eac1740f..03ab9aafafc5b2b6e93ea16c67b98cb749b76b1c 100644 (file)
        this class.
       </para>
 
+      <refsect2>
       <title>Normalized inheritance schemas</title>
       <para>
     Specifying that <symbol>:normalizedp</symbol> is <symbol>T</symbol>
@@ -716,7 +717,7 @@ CLSQL> (title test-user)
 CLSQL> (nick test-user)
 "test-user"
       </screen>
-
+      </refsect2>
     </refsect1>
     <refsect1>
       <title>Examples</title>
index 787b4a3b08b28d1c09672447ad171a28e7286984..e0364fabd825483540f4d323de1c210d69a019dc 100644 (file)
       utilities for enabling and disabling the square bracket reader
       syntax and for constructing symbolic SQL expressions.
     </para>
+    <tip>
+      <title>Tip: just want it on</title>
+      <simpara>
+       <link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link> at the top of each file is easiest.
+      </simpara>
+    </tip>
   </partintro>  
 
   <refentry id="enable-sql-reader-syntax">
       <para> 
         Modifies the default readtable.
       </para>
+      <warning>
+       <para>
+       &clsql; tries to keep track of whether the syntax has already been enabled. This can be problematic if the syntax is somehow disabled externally to &clsql; as future attempts to enable the syntax will do nothing--the system thinks it is already enabled. This may happen if there is an enable, but no disable, in a file that is processed with load or compile-file as the lisp implementation will restore the readtable on completion. Or, even if there is a disable but a compiler-error is encountered before running the disable. If you encounter this try running <link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link> a couple times in the REPL.
+       </para>
+       <para>See <link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link> for an alternative.</para>
+      </warning>
     </refsect1>
     <refsect1>
       <title>Affected by</title>
@@ -77,6 +89,7 @@
         <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member>
         <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member>
         <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member>
+       <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member>
       </simplelist>
     </refsect1>
     <refsect1>
         <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member>
         <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member>
         <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member>
+       <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member>
       </simplelist>
     </refsect1>
     <refsect1>
     </refmeta>
     <refnamediv>
       <refname>LOCALLY-ENABLE-SQL-READER-SYNTAX</refname>
-      <refpurpose>Globally enable square bracket reader syntax.</refpurpose>
+      <refpurpose>Locally enable square bracket reader syntax.</refpurpose>
       <refclass>Macro</refclass>
     </refnamediv>
     <refsect1>
       <para>
         Modifies the default readtable.
       </para>
+      <warning>
+       <para>
+       &clsql; tries to keep track of whether the syntax has already been enabled. This can be problematic if the syntax is somehow disabled externally to &clsql; as future attempts to enable the syntax will do nothing--the system thinks it is already enabled. This may happen if there is an enable, but no disable, in a file that is processed with load or compile-file as the lisp implementation will restore the readtable on completion. Or, even if there is a disable but a compiler-error is encountered before running the disable. If you encounter this try running <link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link> a couple times in the REPL.
+       </para>
+       <para>See <link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link> for an alternative.</para>
+      </warning>
     </refsect1>
     <refsect1>
       <title>Affected by</title>
         <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member>
         <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member>
         <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member>
+       <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member>
       </simplelist>
     </refsect1>
     <refsect1>
         <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member>
         <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member>
         <member><link linkend="restore-sql-reader-syntax-state"><function>restore-sql-reader-syntax-state</function></link></member>
+       <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member>
       </simplelist>
     </refsect1>
     <refsect1>
         <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member>
         <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member>
         <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member>
+       <member><link linkend="file-enable-sql-reader-syntax"><function>file-enable-sql-reader-syntax</function></link></member>
       </simplelist>
     </refsect1>
     <refsect1>
     </refsect1>
   </refentry>
 
+  <refentry id="file-enable-sql-reader-syntax">
+    <refmeta>
+      <refentrytitle>FILE-ENABLE-SQL-READER-SYNTAX</refentrytitle>
+    </refmeta>
+    <refnamediv>
+      <refname>FILE-ENABLE-SQL-READER-SYNTAX</refname>
+      <refpurpose>
+       Enable the square bracket reader syntax for the duration of the file.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsect1>
+      <title>Syntax</title>
+      <synopsis>
+      <function>file-enable-sql-reader-syntax</function> => <returnvalue></returnvalue></synopsis>
+    </refsect1>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <para>None.</para> 
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>Uncoditionally enables the SQL reader syntax. Unlike <link
+      linkend="enable-sql-reader-syntax">
+      <function>enable-sql-reader-syntax</function></link> and <link
+      linkend="disable-sql-reader-syntax">
+      <function>disable-sql-reader-syntax</function></link> which try to keep track of whether
+       the syntax has been enabled or disabled and keep track of the old read-table for restoration this function just enables it unconditionally.
+      </para>
+      <para>Once enabled this way there is no corresponding disable function but instead relies on being used in a file context. The spec for <ulink url="http://www.lispworks.com/documentation/lw51/CLHS/Body/f_load.htm">load</ulink> and <ulink url="http://www.lispworks.com/documentation/lw51/CLHS/Body/f_cmp_fi.htm">compile-file</ulink> states that the *readtable* will be restored after processing the file.</para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <para>Intended to be used at the top of a file that contains sql reader syntax.</para>
+      <screen>
+       (in-package :my-package)
+       (clsql:file-enable-sql-reader-syntax)
+       ...
+       ;;functions that use the square bracket syntax.
+      </screen> 
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>
+        Modifies the readtable for #\[ and #\]
+      </para> 
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para> 
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>
+        None. 
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>See Also</title>
+      <simplelist>
+        <member><link linkend="enable-sql-reader-syntax"><function>enable-sql-reader-syntax</function></link></member>
+        <member><link linkend="disable-sql-reader-syntax"><function>disable-sql-reader-syntax</function></link></member>
+        <member><link linkend="locally-enable-sql-reader-syntax"><function>locally-enable-sql-reader-syntax</function></link></member>
+        <member><link linkend="locally-disable-sql-reader-syntax"><function>locally-disable-sql-reader-syntax</function></link></member>
+      </simplelist>
+    </refsect1>
+    <refsect1>
+      <title>Notes</title>
+      <para> 
+        Unique to &clsql;, not present in &commonsql;.
+      </para>
+    </refsect1>
+  </refentry>
+
   <refentry id="sql">
     <refmeta>
       <refentrytitle>SQL</refentrytitle>
index 382f552955219276e2ba935f8e194b3156b9f5ea..bb87046fb6c8ce494976b9293efbc11d997b7e9d 100644 (file)
@@ -18,6 +18,8 @@
 CONNECT. Meaningful values are :new, :warn-new, :error, :warn-old
 and :old.")
 
+;;TODO: this variable appears to be global, not thread specific and is
+;; not protected when modifying the list.
 (defvar *connected-databases* nil
   "List of active database objects.")
 
@@ -174,6 +176,7 @@ from a pool it will be released to this pool."
                 (setf *default-database* (car *connected-databases*)))
               t))
           (when (database-disconnect database)
+           ;;TODO: RACE COND: 2 threads disconnecting could stomp on *connected-databases*
             (setf *connected-databases* (delete database *connected-databases*))
             (when (eq database *default-database*)
               (setf *default-database* (car *connected-databases*)))
index 8bcc42e964902f388ff840733b49239bb1d36ced..9c17b544dd0268993a6022e13b3677fadb107959 100644 (file)
@@ -425,6 +425,20 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.")
     nil)
   (:documentation "Free the resources of a prepared statement."))
 
+(defgeneric database-acquire-from-conn-pool (database)
+  (:documentation "Acquire a database connection from the pool.  This
+is a chance to test the connection for validity before returning it to
+the user. If this function returns NIL or throws an error that
+database connection is considered bad and we make a new one.
+
+Database objects have a chance to specialize, otherwise the default
+method uses the database-underlying-type and tries to do something
+appropriate."))
+
+(defgeneric database-release-to-conn-pool (database)
+  (:documentation "Chance for the database to cleanup before it is
+  returned to the connection pool."))
+
 ;; Checks for closed database
 
 (defmethod database-disconnect :before ((database database))
index 634acc859f9fa5e3e14f459d2ef77bd67c697ebf..710e5e8e090c45548e4a41d6948ccd35c7c7536c 100644 (file)
                                                      :result-types nil
                                                      :database vd))))
              (when res
+              (setf (slot-value instance 'view-database) vd)
                (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
             (pres)
             (t nil)))))
            (res (select att-ref :from  view-table :where view-qual
                                                   :result-types nil)))
       (when res
+       (setf (slot-value instance 'view-database) vd)
         (get-slot-values-from-view instance (list slot-def) (car res))))))
 
 (defmethod update-slot-with-null ((object standard-db-object)
        (format nil "~F" val))))
 
 (defmethod read-sql-value (val type database db-type)
-  (declare (ignore type database db-type))
-  (read-from-string val))
+  (declare (ignore database db-type))
+  (cond
+    ((null type) val) ;;we have no desired type, just give the value
+    ((typep val type) val) ;;check that it hasn't already been converted.
+    ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it?
+    (T (error "Unable to read-sql-value ~a as type ~a" val type))))
 
 (defmethod read-sql-value (val (type (eql 'string)) database db-type)
   (declare (ignore database db-type))
   (declare (ignore database db-type))
   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
   (etypecase val
-    (string
-     (float (read-from-string val)))
-    (float
-     val)))
+    (string (float (read-from-string val)))
+    (float val)))
+
+(defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
+  (declare (ignore database db-type))
+  ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
+  (etypecase val
+    (string (float
+            (let ((*read-default-float-format* 'double-float))
+              (read-from-string val))
+            1.0d0))
+    (double-float val)
+    (float (coerce val 'double-float))))
 
 (defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
   (declare (ignore database db-type))
index e8294f79ea7e715f2de009551a741af8a9d3fef2..9e9dcb6b76f3bc110b516429424ed2d8d2318af9 100644 (file)
      #:database-destroy
      #:database-probe
      #:database-list
+     #:database-acquire-from-conn-pool
+     #:database-release-to-conn-pool
 
      #:db-backend-has-create/destroy-db?
      #:db-type-has-views?
      #:*loaded-database-types*
      #:reload-database-types
      #:is-database-open
+     #:*db-pool-max-free-connections*
 
      ;; Large objects
      #:database-create-large-object
          #:locally-disable-sql-reader-syntax
          #:locally-enable-sql-reader-syntax
          #:restore-sql-reader-syntax-state
+        #:file-enable-sql-reader-syntax
 
          ;; SQL operations (operations.lisp)
          #:sql-query
index 1fb0c59690e991071e6313e0b13a9cc17cac59ed..38d32cdd21a125c543bcbd4471b087c7cd4ffd3b 100644 (file)
 
 (in-package #:clsql-sys)
 
+(defparameter *db-pool-max-free-connections* 4
+  "Threshold of free-connections in the pool before we disconnect a
+  database rather than returning it to the pool. This is really a heuristic
+that should, on avg keep the free connections about this size.")
+
 (defvar *db-pool* (make-hash-table :test #'equal))
 (defvar *db-pool-lock* (make-process-lock "DB Pool lock"))
 
 (defclass conn-pool ()
   ((connection-spec :accessor connection-spec :initarg :connection-spec)
    (database-type :accessor pool-database-type :initarg :pool-database-type)
-   (free-connections :accessor free-connections
-                     :initform (make-array 5 :fill-pointer 0 :adjustable t))
-   (all-connections :accessor all-connections
-                    :initform (make-array 5 :fill-pointer 0 :adjustable t))
+   (free-connections :accessor free-connections :initform nil)
+   (all-connections :accessor all-connections :initform nil)
    (lock :accessor conn-pool-lock
-         :initform (make-process-lock "Connection pool"))))
-
-(defun acquire-from-conn-pool (pool)
-  (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
-        (when (plusp (length (free-connections pool)))
-          (let ((pconn (vector-pop (free-connections pool))))
-            ;; test if connection still valid.
-            ;; Currently, on supported on MySQL
-            (cond
-              ((eq :mysql (database-type pconn))
-               (handler-case
-                   (database-query "SHOW ERRORS LIMIT 1" pconn nil nil)
-                 (error (e)
-                   ;; we could check for error type 2006 for "SERVER GONE AWAY",
-                   ;; but, it's safer just to disconnect the pooled conn for any error
-                   (warn "Database connection ~S had an error when attempted to be acquired from the pool:
+        :initform (make-process-lock "Connection pool"))))
+
+
+(defun acquire-from-pool (connection-spec database-type &optional pool)
+  "Try to find a working database connection in the pool or create a new
+one if needed. This performs 1 query against the DB to ensure it's still
+valid. When possible (postgres, mssql) that query will be a reset
+command to put the connection back into its default state."
+  (unless (typep pool 'conn-pool)
+    (setf pool (find-or-create-connection-pool connection-spec database-type)))
+  (or
+   (loop for pconn = (with-process-lock ((conn-pool-lock pool) "Acquire")
+                      (pop (free-connections pool)))
+        always pconn
+        thereis
+        ;; test if connection still valid.
+        ;; (e.g. db reboot -> invalid connection )
+        (handler-case
+            (progn (database-acquire-from-conn-pool pconn)
+                   pconn)
+          (sql-database-error (e)
+            ;; we could check for a specific error,
+            ;; but, it's safer just to disconnect the pooled conn for any error ?
+            (warn "Database connection ~S had an error while acquiring from the pool:
   ~S
 Disconnecting.~%"
-                         pconn e)
-                   (ignore-errors (database-disconnect pconn))
-                   nil)
-                 (:no-error (res fields)
-                   (declare (ignore res fields))
-                   pconn)))
-              (t
-               pconn)))))
-      (let ((conn (connect (connection-spec pool)
-                           :database-type (pool-database-type pool)
-                           :if-exists :new
-                           :make-default nil)))
-        (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
-          (vector-push-extend conn (all-connections pool))
-          (setf (conn-pool conn) pool))
-        conn)))
-
-(defun release-to-conn-pool (conn)
-  (let ((pool (conn-pool conn)))
-    (with-process-lock ((conn-pool-lock pool) "Release to pool")
-      (vector-push-extend conn (free-connections pool)))))
+                  pconn e)
+            ;;run database disconnect to give chance for cleanup
+            ;;there, then remove it from the lists of connected
+            ;;databases.
+            (%pool-force-disconnect pconn)
+            (with-process-lock ((conn-pool-lock pool) "remove dead conn")
+              (setf (all-connections pool)
+                    (delete pconn (all-connections pool))))
+            nil)))
+   (let ((conn (connect (connection-spec pool)
+                       :database-type (pool-database-type pool)
+                       :if-exists :new
+                       :make-default nil)))
+     (with-process-lock ((conn-pool-lock pool) "new conection")
+       (push conn (all-connections pool))
+       (setf (conn-pool conn) pool))
+     conn)))
+
+(defun release-to-pool (database)
+  "Release a database connection to the pool. The backend will have a
+chance to do cleanup."
+  (let ((pool (conn-pool database)))
+    (cond
+      ;;We read the list of free-connections outside the lock. This
+      ;;should be fine as long as that list is never dealt with
+      ;;destructively (push and pop destructively modify the place,
+      ;;not the list). Multiple threads getting to this test at the
+      ;;same time might result in the free-connections getting
+      ;;longer... meh.
+      ((>= (length (free-connections pool))
+          *db-pool-max-free-connections*)
+       (%pool-force-disconnect database)
+       (with-process-lock ((conn-pool-lock pool) "Remove extra Conn")
+        (setf (all-connections pool)
+              (delete database (all-connections pool)))))
+      (t
+       ;;let it do cleanup
+       (database-release-to-conn-pool database)
+       (with-process-lock ((conn-pool-lock pool) "Release to pool")
+        (push database (free-connections pool)))))))
+
+(defmethod database-acquire-from-conn-pool (database)
+  (case (database-underlying-type database)
+    (:postgresql
+       (database-execute-command "RESET ALL" database))
+    (:mysql
+       (database-query "SHOW ERRORS LIMIT 1" database nil nil))
+    (:mssql
+       ;; rpc escape sequence since this can't be called as a normal sp.
+       ;;http://msdn.microsoft.com/en-us/library/aa198358%28SQL.80%29.aspx
+       (database-execute-command "{rpc sp_reset_connection}" database))
+    (T
+       (database-query "SELECT 1;"  database '(integer) nil))))
+
+(defmethod database-release-to-conn-pool (database)
+  (case (database-underlying-type database)
+    (:postgresql
+       (ignore-errors
+        ;;http://www.postgresql.org/docs/current/static/sql-discard.html
+        ;;this was introduced relatively recently, wrap in ignore-errors
+        ;;so that it doesn't choke older versions.
+        (database-execute-command "DISCARD ALL" database)))))
 
 (defun clear-conn-pool (pool)
   (with-process-lock ((conn-pool-lock pool) "Clear pool")
-    (loop for conn across (all-connections pool)
-          do (setf (conn-pool conn) nil)
-          ;; disconnect may error if remote side closed connection
-          (ignore-errors (disconnect :database conn)))
-    (setf (fill-pointer (free-connections pool)) 0)
-    (setf (fill-pointer (all-connections pool)) 0))
+    (mapc #'%pool-force-disconnect (all-connections pool))
+    (setf (all-connections pool) nil
+         (free-connections pool) nil))
   nil)
 
 (defun find-or-create-connection-pool (connection-spec database-type)
@@ -82,33 +131,33 @@ Disconnecting.~%"
 if not found"
   (with-process-lock (*db-pool-lock* "Find-or-create connection")
     (let* ((key (list connection-spec database-type))
-           (conn-pool (gethash key *db-pool*)))
+          (conn-pool (gethash key *db-pool*)))
       (unless conn-pool
-        (setq conn-pool (make-instance 'conn-pool
-                                       :connection-spec connection-spec
-                                       :pool-database-type database-type))
-        (setf (gethash key *db-pool*) conn-pool))
+       (setq conn-pool (make-instance 'conn-pool
+                                      :connection-spec connection-spec
+                                      :pool-database-type database-type))
+       (setf (gethash key *db-pool*) conn-pool))
       conn-pool)))
 
-(defun acquire-from-pool (connection-spec database-type &optional pool)
-  (unless (typep pool 'conn-pool)
-    (setf pool (find-or-create-connection-pool connection-spec database-type)))
-  (acquire-from-conn-pool pool))
-
-(defun release-to-pool (database)
-  (release-to-conn-pool database))
-
 (defun disconnect-pooled (&optional clear)
-  "Disconnects all connections in the pool."
+  "Disconnects all connections in the pool. When clear, also deletes
+the pool objects."
   (with-process-lock (*db-pool-lock* "Disconnect pooled")
     (maphash
      #'(lambda (key conn-pool)
-         (declare (ignore key))
-         (clear-conn-pool conn-pool))
+        (declare (ignore key))
+        (clear-conn-pool conn-pool))
      *db-pool*)
     (when clear (clrhash *db-pool*)))
   t)
 
+(defun %pool-force-disconnect (database)
+  "Force disconnection of a connection from the pool."
+  ;;so it isn't just returned to pool
+  (setf (conn-pool database) nil)
+  ;; disconnect may error if remote side closed connection
+  (ignore-errors (disconnect :database database)))
+
 ;(defun pool-start-sql-recording (pool &key (types :command))
 ;  "Start all stream in the pool recording actions of TYPES"
 ;  (dolist (con (pool-connections pool))
index 1aec1caa8fc55f3f23025b3848b1a88bc038dd68..7e1906b9e4d22055a497c54ac546f5335f3803e9 100644 (file)
@@ -64,6 +64,15 @@ the current syntax state."
   '(eval-when (:compile-toplevel :load-toplevel :execute)
     (%enable-sql-reader-syntax)))
 
+(defmacro file-enable-sql-reader-syntax ()
+  "Turns on the SQL reader syntax for the rest of the file.
+The CL spec says that when finished loading a file the original
+*readtable* is restored.  clhs COMPILE-FILE"
+  '(eval-when (:compile-toplevel :load-toplevel :execute)
+    (setf *readtable* (copy-readtable))
+    (set-macro-character *sql-macro-open-char* #'sql-reader-open)
+    (set-macro-character *sql-macro-close-char* (get-macro-character #\)))))
+
 (defun %enable-sql-reader-syntax ()
   (unless *original-readtable*
     (setf *original-readtable* *readtable*