;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id$
-;;;;
;;;; Base database functions
;;;;
;;;; This file is part of CLSQL.
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.")
(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
(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 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,
(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
(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
- (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
(: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))))
(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*)))
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)
- (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
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
- (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
(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)
(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)))
(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)
+(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
-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))
-
projects / clsql.git / blobdiff