X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fdatabase.lisp;h=299eadca439fc07f1c0955c417595cc6eca1650c;hp=9b716444f0256b51c13c98a2a4ffd0a57588561a;hb=326e9dc298298431a7122ed57d14a60bccd95923;hpb=e567409d9fff3f7231c2a0bb69b345e19de2b246 diff --git a/sql/database.lisp b/sql/database.lisp index 9b71644..299eadc 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -1,8 +1,6 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ -;;;; ;;;; Base database functions ;;;; ;;;; This file is part of CLSQL. @@ -14,12 +12,17 @@ (in-package #:clsql-sys) +(defvar *default-encoding* + (or #+sbcl sb-impl::*default-external-format* + :utf-8)) (defvar *connect-if-exists* :error "Default value for the if-exists keyword argument in calls to 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.") @@ -72,7 +75,8 @@ error is signalled." &key (if-exists *connect-if-exists*) (make-default t) (pool nil) - (database-type *default-database-type*)) + (database-type *default-database-type*) + (encoding *default-encoding*)) "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, @@ -99,10 +103,11 @@ be taken from this pool." (asdf:operate 'asdf:load-op (ensure-keyword (concatenate 'string (symbol-name '#:clsql-) - (symbol-name database-type))))) + (symbol-name database-type))) + :verbose nil)) (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)) @@ -150,6 +155,7 @@ be taken from this pool." (setf (slot-value result 'state) :open) (pushnew result *connected-databases*) (when make-default (setq *default-database* result)) + (setf (encoding result) encoding) result)))) @@ -166,12 +172,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) - (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) + ;;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*))) @@ -188,7 +196,9 @@ 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 - (declare (ignore ,@(remove '&optional template))) + (declare (ignore ,@(remove-if + (lambda (x) (member x '(&key &rest &optional))) + template))) t) (error () (error 'sql-user-error @@ -229,7 +239,7 @@ database connection cannot be closed, an error is signalled." (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) @@ -279,38 +289,57 @@ database is printed." (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)) -(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)) -(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)) -(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)) +(defun encoding (db) + (or (when (typep db 'database) + (slot-value db 'encoding)) + *default-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*)) + (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 @@ -320,7 +349,8 @@ from the body. MAKE-DEFAULT has a default value of NIL." :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)) @@ -331,4 +361,3 @@ from the body. MAKE-DEFAULT has a default value of NIL." `(progv '(*default-database*) (list ,database) ,@body)) -