Pass encoding argument to pooled connections

[clsql.git] / sql / database.lisp

diff --git a/sql/database.lisp b/sql/database.lisp
index c07cf7b1aad8b515e9ecb219d89709d3b8b4cc8d..982973e6d23695d84b96f11968a246add9220780 100644 (file)
--- a/sql/database.lisp
+++ b/sql/database.lisp
@@ -1,8 +1,6 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;

-;;;; $Id$
-;;;;

 ;;;; Base database functions
 ;;;;
 ;;;; This file is part of CLSQL.
 ;;;; Base database functions
 ;;;;
 ;;;; This file is part of CLSQL.


@@ -20,6 +18,8 @@
 CONNECT. Meaningful values are :new, :warn-new, :error, :warn-old
 and :old.")
 
 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.")
 
 (defvar *connected-databases* nil
   "List of active database objects.")
 


@@ -61,18 +61,19 @@ error is signalled."
            (cerror "Return nil."
                    'sql-database-error
                    :message
            (cerror "Return nil."
                    'sql-database-error
                    :message

-                  (format nil "There exists ~A database called ~A."
-                          (if (zerop count) "no" "more than one")
-                          database)))))
+                   (format nil "There exists ~A database called ~A."
+                           (if (zerop count) "no" "more than one")
+                           database)))))

     (null
      (error "A database must be specified rather than NIL."))))
 
 
 (defun connect (connection-spec
     (null
      (error "A database must be specified rather than NIL."))))
 
 
 (defun connect (connection-spec

-               &key (if-exists *connect-if-exists*)
-               (make-default t)
+                &key (if-exists *connect-if-exists*)
+                (make-default t)

                 (pool nil)
                 (pool nil)

-               (database-type *default-database-type*))
+                (database-type *default-database-type*)
+                (encoding nil))

   "Connects to a database of the supplied DATABASE-TYPE which
 defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific
 connection specification CONNECTION-SPEC. The value of IF-EXISTS,
   "Connects to a database of the supplied DATABASE-TYPE which
 defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific
 connection specification CONNECTION-SPEC. The value of IF-EXISTS,


@@ -97,12 +98,13 @@ be taken from this pool."
 
   (unless (member database-type *loaded-database-types*)
     (asdf:operate 'asdf:load-op (ensure-keyword
 
   (unless (member database-type *loaded-database-types*)
     (asdf:operate 'asdf:load-op (ensure-keyword

-                                (concatenate 'string
-                                             (symbol-name '#:clsql-)
-                                             (symbol-name database-type)))))
+                                 (concatenate 'string
+                                              (symbol-name '#:clsql-)
+                                              (symbol-name database-type)))
+                  :verbose nil))

 
   (if pool
 
   (if pool

-      (let ((conn (acquire-from-pool connection-spec database-type pool)))
+      (let ((conn (acquire-from-pool connection-spec database-type pool encoding)))

         (when make-default (setq *default-database* conn))
         conn)
       (let* ((db-name (database-name-from-spec connection-spec database-type))
         (when make-default (setq *default-database* conn))
         conn)
       (let* ((db-name (database-name-from-spec connection-spec database-type))


@@ -116,17 +118,17 @@ be taken from this pool."
                (setq result
                      (database-connect connection-spec database-type))
                (warn 'sql-warning
                (setq result
                      (database-connect connection-spec database-type))
                (warn 'sql-warning

-                    :message
-                    (format nil
-                            "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
-                            result (database-name result) old-db)))
-             (:error
+                     :message
+                     (format nil
+                             "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
+                             result (database-name result) old-db)))
+              (:error

                (restart-case
                (restart-case

-                  (error 'sql-connection-error
-                         :message
-                         (format nil "There is an existing connection ~A to database ~A."
-                         old-db
-                         (database-name old-db)))
+                   (error 'sql-connection-error
+                          :message
+                          (format nil "There is an existing connection ~A to database ~A."
+                          old-db
+                          (database-name old-db)))

                  (create-new ()
                    :report "Create a new connection."
                    (setq result
                  (create-new ()
                    :report "Create a new connection."
                    (setq result


@@ -137,19 +139,20 @@ be taken from this pool."
               (:warn-old
                (setq result old-db)
                (warn 'sql-warning
               (:warn-old
                (setq result old-db)
                (warn 'sql-warning

-                    :message
-                    (format nil
-                            "Using existing connection ~A to database ~A."
-                            old-db
-                            (database-name old-db))))
+                     :message
+                     (format nil
+                             "Using existing connection ~A to database ~A."
+                             old-db
+                             (database-name old-db))))

               (:old
                (setq result old-db)))
             (setq result
                   (database-connect connection-spec database-type)))
         (when result
               (:old
                (setq result old-db)))
             (setq result
                   (database-connect connection-spec database-type)))
         (when result

-         (setf (slot-value result 'state) :open)
+          (setf (slot-value result 'state) :open)

           (pushnew result *connected-databases*)
           (when make-default (setq *default-database* result))
           (pushnew result *connected-databases*)
           (when make-default (setq *default-database* result))

+          (setf (encoding result) encoding)

           result))))
 
 
           result))))
 
 


@@ -166,12 +169,14 @@ from a pool it will be released to this pool."
   (let ((database (find-database database :errorp (and database error))))
     (when database
       (if (conn-pool database)
   (let ((database (find-database database :errorp (and database error))))
     (when database
       (if (conn-pool database)

-          (when (release-to-pool database)
-            (setf *connected-databases* (delete database *connected-databases*))
-            (when (eq database *default-database*)
-              (setf *default-database* (car *connected-databases*)))
-            t)
+          (with-process-lock ((conn-pool-lock (conn-pool database)) "Delete from pool")
+            (when (release-to-pool database)
+              (setf *connected-databases* (delete database *connected-databases*))
+              (when (eq database *default-database*)
+                (setf *default-database* (car *connected-databases*)))
+              t))

           (when (database-disconnect database)
           (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*)))
             (setf *connected-databases* (delete database *connected-databases*))
             (when (eq database *default-database*)
               (setf *default-database* (car *connected-databases*)))


@@ -194,10 +199,10 @@ is called by database backends."
      (error 'sql-user-error
       :message
       (format nil
      (error 'sql-user-error
       :message
       (format nil

-             "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
-             ,connection-spec
-             ,database-type
-             (quote ,template))))))
+              "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
+              ,connection-spec
+              ,database-type
+              (quote ,template))))))

 
 (defun reconnect (&key (database *default-database*) (error nil) (force t))
   "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to
 
 (defun reconnect (&key (database *default-database*) (error nil) (force t))
   "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to


@@ -213,23 +218,23 @@ closed, if FORCE is non-nil, as it is by default, the connection
 is closed and errors are suppressed. If force is nil and the
 database connection cannot be closed, an error is signalled."
   (let ((db (etypecase database
 is closed and errors are suppressed. If force is nil and the
 database connection cannot be closed, an error is signalled."
   (let ((db (etypecase database

-             (database database)
-             ((or string list)
-              (let ((db (find-database database :errorp nil)))
-                (when (null db)
-                  (if (and database error)
-                      (error 'sql-connection-error
-                             :message
-                             (format nil "Unable to find database with connection-spec ~A." database))
-                      (return-from reconnect nil)))
-                db)))))
+              (database database)
+              ((or string list)
+               (let ((db (find-database database :errorp nil)))
+                 (when (null db)
+                   (if (and database error)
+                       (error 'sql-connection-error
+                              :message
+                              (format nil "Unable to find database with connection-spec ~A." database))
+                       (return-from reconnect nil)))
+                 db)))))

 
     (when (is-database-open db)
       (if force
 
     (when (is-database-open db)
       (if force

-         (ignore-errors (disconnect :database db))
-         (disconnect :database db :error nil)))
+          (ignore-errors (disconnect :database db))
+          (disconnect :database db :error nil)))

 
 

-    (connect (connection-spec db))))
+    (connect (connection-spec db) :encoding (encoding db))))

 
 
 (defun status (&optional full)
 
 
 (defun status (&optional full)


@@ -240,24 +245,24 @@ database is printed."
   (flet ((get-data ()
            (let ((data '()))
              (dolist (db (connected-databases) data)
   (flet ((get-data ()
            (let ((data '()))
              (dolist (db (connected-databases) data)

-              (push
-               (append
-                (list (if (equal db *default-database*) "*" "")
-                      (database-name db)
-                      (string-downcase (string (database-type db)))
-                      (cond ((and (command-recording-stream db)
-                                  (result-recording-stream db))
-                             "Both")
-                            ((command-recording-stream db) "Commands")
-                            ((result-recording-stream db) "Results")
-                            (t "nil")))
-                (when full
-                  (list
-                   (if (conn-pool db) "t" "nil")
-                   (format nil "~A" (length (database-list-tables db)))
-                   (format nil "~A" (length (database-list-views db))))))
-               data))))
-        (compute-sizes (data)
+               (push
+                (append
+                 (list (if (equal db *default-database*) "*" "")
+                       (database-name db)
+                       (string-downcase (string (database-type db)))
+                       (cond ((and (command-recording-stream db)
+                                   (result-recording-stream db))
+                              "Both")
+                             ((command-recording-stream db) "Commands")
+                             ((result-recording-stream db) "Results")
+                             (t "nil")))
+                 (when full
+                   (list
+                    (if (conn-pool db) "t" "nil")
+                    (format nil "~A" (length (database-list-tables db)))
+                    (format nil "~A" (length (database-list-views db))))))
+                data))))
+         (compute-sizes (data)

            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
                    (apply #'mapcar (cons #'list data))))
          (print-separator (size)
            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
                    (apply #'mapcar (cons #'list data))))
          (print-separator (size)


@@ -266,9 +271,9 @@ database is printed."
     (let ((data (get-data)))
       (when data
         (let* ((titles (if full
     (let ((data (get-data)))
       (when data
         (let* ((titles (if full

-                          (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
-                                "TABLES" "VIEWS")
-                          (list "" "DATABASE" "TYPE" "RECORDING")))
+                           (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
+                                 "TABLES" "VIEWS")
+                           (list "" "DATABASE" "TYPE" "RECORDING")))

                (sizes (compute-sizes (cons titles data)))
                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))
                (sizes (compute-sizes (cons titles data)))
                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))


@@ -279,38 +284,56 @@ database is printed."
           (print-separator total-size))))
     (values)))
 
           (print-separator total-size))))
     (values)))
 

-(defun create-database (connection-spec &key database-type)
+(defun create-database (connection-spec &key (database-type *default-database-type*))

   "This function creates a database in the database system specified
 by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-create connection-spec database-type))
 
   "This function creates a database in the database system specified
 by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-create connection-spec database-type))
 

-(defun probe-database (connection-spec &key database-type)
+(defun probe-database (connection-spec &key (database-type *default-database-type*))

   "This function tests for the existence of a database in the database
 system specified by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-probe connection-spec database-type))
 
   "This function tests for the existence of a database in the database
 system specified by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-probe connection-spec database-type))
 

-(defun destroy-database (connection-spec &key database-type)
+(defun destroy-database (connection-spec &key (database-type *default-database-type*))

   "This function destroys a database in the database system specified
 by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-destroy connection-spec database-type))
 
   "This function destroys a database in the database system specified
 by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-destroy connection-spec database-type))
 

-(defun list-databases (connection-spec &key database-type)
+(defun list-databases (connection-spec &key (database-type *default-database-type*))

   "This function returns a list of databases existing in the database
 system specified by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-list connection-spec database-type))
 
   "This function returns a list of databases existing in the database
 system specified by DATABASE-TYPE."
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-list connection-spec database-type))
 

+(defun encoding (db)
+  (when (typep db 'database)
+    (slot-value db 'encoding)))
+
+(defun (setf encoding) (encoding db)
+  (when (typep db 'database)
+    (setf (slot-value db 'encoding) encoding)
+    (when (eql (slot-value db 'state) :open)
+      (case (database-type db)
+        ;; FIXME: If database object is open then
+        ;; send command to SQL engine specifying the character
+        ;; encoding for the database
+        (:mysql
+         )
+        ((:postgresql :postgresql-socket)
+         )))))
+

 (defmacro with-database ((db-var connection-spec
                                  &key make-default pool
                                  (if-exists *connect-if-exists*)
 (defmacro with-database ((db-var connection-spec
                                  &key make-default pool
                                  (if-exists *connect-if-exists*)

-                                 (database-type *default-database-type*))
+                                 (database-type *default-database-type*)
+                                 (encoding nil))

                                  &body body)
   "Evaluate the body in an environment, where DB-VAR is bound to the
 database connection given by CONNECTION-SPEC and CONNECT-ARGS.  The
                                  &body body)
   "Evaluate the body in an environment, where DB-VAR is bound to the
 database connection given by CONNECTION-SPEC and CONNECT-ARGS.  The


@@ -320,7 +343,8 @@ from the body. MAKE-DEFAULT has a default value of NIL."
                            :database-type ,database-type
                            :if-exists ,if-exists
                            :pool ,pool
                            :database-type ,database-type
                            :if-exists ,if-exists
                            :pool ,pool

-                           :make-default ,make-default)))
+                           :make-default ,make-default
+                           :encoding ,encoding)))

      (unwind-protect
       (let ((,db-var ,db-var))
         (progn ,@body))
      (unwind-protect
       (let ((,db-var ,db-var))
         (progn ,@body))


@@ -331,4 +355,3 @@ from the body. MAKE-DEFAULT has a default value of NIL."
   `(progv '(*default-database*)
        (list ,database)
      ,@body))
   `(progv '(*default-database*)
        (list ,database)
      ,@body))

-