X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fdatabase.lisp;h=299eadca439fc07f1c0955c417595cc6eca1650c;hp=d59218176370e8c2ce1ac272242d4c4dffad9233;hb=HEAD;hpb=4c89485f5cdb21a334de9c35adfded30db0c75e7 diff --git a/sql/database.lisp b/sql/database.lisp index d592181..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,16 +12,17 @@ (in-package #:clsql-sys) -(setf (documentation 'database-name 'function) - "Returns the name of a database.") - -;;; Database handling +(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.") @@ -52,7 +51,7 @@ error is signalled." (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 @@ -65,16 +64,19 @@ error is signalled." (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 - &key (if-exists *connect-if-exists*) - (make-default t) + &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, @@ -93,18 +95,21 @@ be taken from this pool." (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))) - + (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 - (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 @@ -116,17 +121,17 @@ be taken from this pool." (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 - (error 'sql-connection-error - :message - "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 @@ -137,19 +142,20 @@ be taken from this pool." (: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 - (setf (slot-value result 'state) :open) + (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*))) @@ -187,17 +195,19 @@ 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 - (destructuring-bind ,template ,connection-spec - (declare (ignore ,@(remove '&optional template))) + (destructuring-bind ,template ,connection-spec + (declare (ignore ,@(remove-if + (lambda (x) (member x '(&key &rest &optional))) + template))) t) - (error () + (error () (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 @@ -213,25 +223,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 - (database database) - ((or string list) - (let ((db (find-database database :errorp nil))) - (when (null db) - (if (and database error) - (error 'clsql-generic-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 - (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 @@ -240,24 +250,24 @@ database is printed." (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) @@ -265,10 +275,10 @@ database is printed." (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))) @@ -279,44 +289,75 @@ 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)) -(defmacro with-database ((db-var connection-spec &rest connect-args) &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 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))) +(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*) + (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 +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)) -