Pass encoding argument to pooled connections

[clsql.git] / sql / database.lisp

diff --git a/sql/database.lisp b/sql/database.lisp
index 706ccbf7cc1c323448a2c8732ddf8e4a2647d6a9..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.")
 


@@ -48,7 +48,7 @@ error is signalled."
     (database
      (values database 1))
     (string
     (database
      (values database 1))
     (string

-     (let* ((matches (remove-if 
+     (let* ((matches (remove-if

                       #'(lambda (db)
                           (not (and (string= (database-name db) database)
                                     (if db-type
                       #'(lambda (db)
                           (not (and (string= (database-name db) database)
                                     (if db-type


@@ -61,16 +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
 
 
 (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,


@@ -89,18 +92,21 @@ be taken from this pool."
 
   (unless database-type
     (error 'sql-database-error :message "Must specify a database-type."))
 
   (unless database-type
     (error 'sql-database-error :message "Must specify a database-type."))

-  
+

   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))

-  
+

   (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

-      (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))
              (old-db (unless (eq if-exists :new)
                        (find-database db-name :db-type database-type
       (let* ((db-name (database-name-from-spec connection-spec database-type))
              (old-db (unless (eq if-exists :new)
                        (find-database db-name :db-type database-type


@@ -112,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


@@ -133,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))))
 
 


@@ -162,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*)))


@@ -183,17 +192,17 @@ from a pool it will be released to this pool."
 and signal an sql-user-error if they don't match. This function
 is called by database backends."
   `(handler-case
 and signal an sql-user-error if they don't match. This function
 is called by database backends."
   `(handler-case

-    (destructuring-bind ,template ,connection-spec 
+    (destructuring-bind ,template ,connection-spec

       (declare (ignore ,@(remove '&optional template)))
       t)
       (declare (ignore ,@(remove '&optional template)))
       t)

-    (error () 
+    (error ()

      (error 'sql-user-error
       :message
      (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))))))
+      (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))))))

 
 (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


@@ -209,25 +218,25 @@ 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)))
-    
-    (connect (connection-spec db))))
+          (ignore-errors (disconnect :database db))
+          (disconnect :database db :error nil)))
+
+    (connect (connection-spec db) :encoding (encoding db))))
+

 
 

-  

 (defun status (&optional full)
   "Prints information about the currently connected databases to
 *STANDARD-OUTPUT*. The argument FULL is nil by default and a
 (defun status (&optional full)
   "Prints information about the currently connected databases to
 *STANDARD-OUTPUT*. The argument FULL is nil by default and a


@@ -236,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)


@@ -261,10 +270,10 @@ database is printed."
     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
     (let ((data (get-data)))
       (when data
     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
     (let ((data (get-data)))
       (when data

-        (let* ((titles (if full 
-                          (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" 
-                                "TABLES" "VIEWS")
-                          (list "" "DATABASE" "TYPE" "RECORDING")))
+        (let* ((titles (if full
+                           (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)))


@@ -275,53 +284,74 @@ 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))
 

-(defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
+(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*)
+                                 (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
 connection is automatically closed or released to the pool on exit
   "Evaluate the body in an environment, where DB-VAR is bound to the
 database connection given by CONNECTION-SPEC and CONNECT-ARGS.  The
 connection is automatically closed or released to the pool on exit

-from the body."
-  (let ((result (gensym "result-")))
-    (unless db-var (setf db-var '*default-database*))
-    `(let ((,db-var (connect ,connection-spec ,@connect-args))
-          (,result nil))
-      (unwind-protect
-          (let ((,db-var ,db-var))
-            (setf ,result (progn ,@body)))
-       (disconnect :database ,db-var))
-      ,result)))
-
+from the body. MAKE-DEFAULT has a default value of NIL."
+  `(let ((,db-var (connect ,connection-spec
+                           :database-type ,database-type
+                           :if-exists ,if-exists
+                           :pool ,pool
+                           :make-default ,make-default
+                           :encoding ,encoding)))
+     (unwind-protect
+      (let ((,db-var ,db-var))
+        (progn ,@body))
+       (disconnect :database ,db-var))))

 
 (defmacro with-default-database ((database) &rest body)
   "Perform BODY with DATABASE bound as *default-database*."
   `(progv '(*default-database*)
        (list ,database)
      ,@body))
 
 (defmacro with-default-database ((database) &rest body)
   "Perform BODY with DATABASE bound as *default-database*."
   `(progv '(*default-database*)
        (list ,database)
      ,@body))

-