From: Nathan Bird Date: Tue, 2 Mar 2010 23:24:32 +0000 (-0500) Subject: Merge branch 'master' into development X-Git-Tag: v5.0.5~8 X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=96cc4dd98e77b8a1f83fa850e3348219c957b7ef;hp=2b2bbca189075b6dfc9533f41dcf64a572d20550;p=clsql.git Merge branch 'master' into development (appears to be spurious, should be the same as 406feeb749bb475bec8077a2716a5b6089bd9072) --- diff --git a/ChangeLog b/ChangeLog index 02308e9..63b51ba 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +2010-03-02 Nathan Bird + * doc/: Added a README on how to build doc; now builds on Ubuntu. + * sql/oodml.lisp: READ-SQL-VALUE now has explicit method for + handling double-floats and the default method will no longer + attempt to convert values that have already been converted. + * sql/syntax.lisp: Introduce file-enable-sql-reader-syntax which + enables the syntax for the scope of the file without trying to + keep track of the current syntax state. + * sql/pool.lisp: Introduce + clsql-sys:*db-pool-max-free-connections* which is a heuristic + threshold for when to disconnect a connection rather than + returning it to the pool. + * sql/pool.lisp: Check connections for validity before returning + to the user. + 2010-03-01 Kevin Rosenberg * db-mysql/mysql-api.lisp: Remove spurious enumeration diff --git a/TODO b/TODO index 4b85e96..795ec6a 100644 --- a/TODO +++ b/TODO @@ -22,3 +22,6 @@ POSSIBLE EXTENSIONS * improve large object api and extend to databases beyond postgresql * add support for prepared statements + +RACE CONDITIONS +* sql/databases.lisp: *connected-databases* is shared globally but not modified in a threadsafe manner. diff --git a/doc/Makefile b/doc/Makefile index 25c1452..59a524b 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -26,6 +26,7 @@ SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*') REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*') MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*') DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*') +UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*') ifneq (${DEBIAN},0) @@ -45,6 +46,10 @@ else else ifneq (${DARWIN},0) OS=darwin + else + ifneq (${UBUNTU},0) + OS:=debian + endif endif endif endif diff --git a/doc/README b/doc/README new file mode 100644 index 0000000..5c0c268 --- /dev/null +++ b/doc/README @@ -0,0 +1,24 @@ +Building the documentation: + +You will need the following packages: + * xsltproc + * docbook + * docbook-xml + * docbook-xsl + * docbook-xsl-doc-html + * fop + +These are the debian/ubuntu package names; on other systems there are probably similar. + + +General Build: +> make + +Check the validity of the source +> make check + +Build just the html: +> make html + +Build just the pdf: +> make pdf diff --git a/doc/csql.xml b/doc/csql.xml index 4787898..f494441 100644 --- a/doc/csql.xml +++ b/doc/csql.xml @@ -465,24 +465,24 @@ There are other :join-info options available in &clsql;, but we will save those till we get to the many-to-many relation examples. - - Object Oriented Class Relations - - -&clsql; provides an Object Oriented Data Definition Language, which -provides a mapping from &sql; tables to CLOS objects. By default class -inheritance is handled by including all the columns from parent -classes into the child class. This means your database schema becomes -very much denormalized. The class option :normalizedp -can be used to disable the default behaviour and have &clsql; -normalize the database schemas of inherited classes. - - - -See def-view-class -for more information. - - + + Object Oriented Class Relations + + + &clsql; provides an Object Oriented Data Definition Language, which + provides a mapping from &sql; tables to CLOS objects. By default class + inheritance is handled by including all the columns from parent + classes into the child class. This means your database schema becomes + very much denormalized. The class option :normalizedp + can be used to disable the default behaviour and have &clsql; + normalize the database schemas of inherited classes. + + + + See def-view-class + for more information. + + diff --git a/doc/ref-ooddl.xml b/doc/ref-ooddl.xml index de79f21..03ab9aa 100644 --- a/doc/ref-ooddl.xml +++ b/doc/ref-ooddl.xml @@ -616,6 +616,7 @@ this class. + Normalized inheritance schemas Specifying that :normalizedp is T @@ -716,7 +717,7 @@ CLSQL> (title test-user) CLSQL> (nick test-user) "test-user" - + Examples diff --git a/doc/ref-syntax.xml b/doc/ref-syntax.xml index 787b4a3..e0364fa 100644 --- a/doc/ref-syntax.xml +++ b/doc/ref-syntax.xml @@ -16,6 +16,12 @@ utilities for enabling and disabling the square bracket reader syntax and for constructing symbolic SQL expressions. + + Tip: just want it on + + file-enable-sql-reader-syntax at the top of each file is easiest. + + @@ -57,6 +63,12 @@ Modifies the default readtable. + + + &clsql; tries to keep track of whether the syntax has already been enabled. This can be problematic if the syntax is somehow disabled externally to &clsql; as future attempts to enable the syntax will do nothing--the system thinks it is already enabled. This may happen if there is an enable, but no disable, in a file that is processed with load or compile-file as the lisp implementation will restore the readtable on completion. Or, even if there is a disable but a compiler-error is encountered before running the disable. If you encounter this try running disable-sql-reader-syntax a couple times in the REPL. + + See file-enable-sql-reader-syntax for an alternative. + Affected by @@ -77,6 +89,7 @@ locally-enable-sql-reader-syntax locally-disable-sql-reader-syntax restore-sql-reader-syntax-state + file-enable-sql-reader-syntax @@ -151,6 +164,7 @@ locally-enable-sql-reader-syntax locally-disable-sql-reader-syntax restore-sql-reader-syntax-state + file-enable-sql-reader-syntax @@ -172,7 +186,7 @@ LOCALLY-ENABLE-SQL-READER-SYNTAX - Globally enable square bracket reader syntax. + Locally enable square bracket reader syntax. Macro @@ -210,6 +224,12 @@ Modifies the default readtable. + + + &clsql; tries to keep track of whether the syntax has already been enabled. This can be problematic if the syntax is somehow disabled externally to &clsql; as future attempts to enable the syntax will do nothing--the system thinks it is already enabled. This may happen if there is an enable, but no disable, in a file that is processed with load or compile-file as the lisp implementation will restore the readtable on completion. Or, even if there is a disable but a compiler-error is encountered before running the disable. If you encounter this try running disable-sql-reader-syntax a couple times in the REPL. + + See file-enable-sql-reader-syntax for an alternative. + Affected by @@ -228,6 +248,7 @@ disable-sql-reader-syntax locally-disable-sql-reader-syntax restore-sql-reader-syntax-state + file-enable-sql-reader-syntax @@ -310,6 +331,7 @@ disable-sql-reader-syntax locally-enable-sql-reader-syntax restore-sql-reader-syntax-state + file-enable-sql-reader-syntax @@ -394,6 +416,7 @@ disable-sql-reader-syntax locally-enable-sql-reader-syntax locally-disable-sql-reader-syntax + file-enable-sql-reader-syntax @@ -409,6 +432,80 @@ + + + FILE-ENABLE-SQL-READER-SYNTAX + + + FILE-ENABLE-SQL-READER-SYNTAX + + Enable the square bracket reader syntax for the duration of the file. + + Macro + + + Syntax + + file-enable-sql-reader-syntax => + + + Arguments and Values + None. + + + Description + Uncoditionally enables the SQL reader syntax. Unlike + enable-sql-reader-syntax and + disable-sql-reader-syntax which try to keep track of whether + the syntax has been enabled or disabled and keep track of the old read-table for restoration this function just enables it unconditionally. + + Once enabled this way there is no corresponding disable function but instead relies on being used in a file context. The spec for load and compile-file states that the *readtable* will be restored after processing the file. + + + Examples + Intended to be used at the top of a file that contains sql reader syntax. + + (in-package :my-package) + (clsql:file-enable-sql-reader-syntax) + ... + ;;functions that use the square bracket syntax. + + + + Side Effects + + Modifies the readtable for #\[ and #\] + + + + Affected by + None. + + + Exceptional Situations + + None. + + + + See Also + + enable-sql-reader-syntax + disable-sql-reader-syntax + locally-enable-sql-reader-syntax + locally-disable-sql-reader-syntax + + + + Notes + + Unique to &clsql;, not present in &commonsql;. + + + + SQL diff --git a/sql/database.lisp b/sql/database.lisp index 382f552..bb87046 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -18,6 +18,8 @@ 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.") @@ -174,6 +176,7 @@ from a pool it will be released to this pool." (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*))) diff --git a/sql/db-interface.lisp b/sql/db-interface.lisp index 8bcc42e..9c17b54 100644 --- a/sql/db-interface.lisp +++ b/sql/db-interface.lisp @@ -425,6 +425,20 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") nil) (:documentation "Free the resources of a prepared statement.")) +(defgeneric database-acquire-from-conn-pool (database) + (:documentation "Acquire a database connection from the pool. This +is a chance to test the connection for validity before returning it to +the user. If this function returns NIL or throws an error that +database connection is considered bad and we make a new one. + +Database objects have a chance to specialize, otherwise the default +method uses the database-underlying-type and tries to do something +appropriate.")) + +(defgeneric database-release-to-conn-pool (database) + (:documentation "Chance for the database to cleanup before it is + returned to the connection pool.")) + ;; Checks for closed database (defmethod database-disconnect :before ((database database)) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 634acc8..710e5e8 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -332,6 +332,7 @@ :result-types nil :database vd)))) (when res + (setf (slot-value instance 'view-database) vd) (get-slot-values-from-view instance (mapcar #'car sels) (car res)))) (pres) (t nil))))) @@ -358,6 +359,7 @@ (res (select att-ref :from view-table :where view-qual :result-types nil))) (when res + (setf (slot-value instance 'view-database) vd) (get-slot-values-from-view instance (list slot-def) (car res)))))) (defmethod update-slot-with-null ((object standard-db-object) @@ -580,8 +582,12 @@ (format nil "~F" val)))) (defmethod read-sql-value (val type database db-type) - (declare (ignore type database db-type)) - (read-from-string val)) + (declare (ignore database db-type)) + (cond + ((null type) val) ;;we have no desired type, just give the value + ((typep val type) val) ;;check that it hasn't already been converted. + ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it? + (T (error "Unable to read-sql-value ~a as type ~a" val type)))) (defmethod read-sql-value (val (type (eql 'string)) database db-type) (declare (ignore database db-type)) @@ -635,10 +641,19 @@ (declare (ignore database db-type)) ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) (etypecase val - (string - (float (read-from-string val))) - (float - val))) + (string (float (read-from-string val))) + (float val))) + +(defmethod read-sql-value (val (type (eql 'double-float)) database db-type) + (declare (ignore database db-type)) + ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...) + (etypecase val + (string (float + (let ((*read-default-float-format* 'double-float)) + (read-from-string val)) + 1.0d0)) + (double-float val) + (float (coerce val 'double-float)))) (defmethod read-sql-value (val (type (eql 'boolean)) database db-type) (declare (ignore database db-type)) diff --git a/sql/package.lisp b/sql/package.lisp index e8294f7..9e9dcb6 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -136,6 +136,8 @@ #:database-destroy #:database-probe #:database-list + #:database-acquire-from-conn-pool + #:database-release-to-conn-pool #:db-backend-has-create/destroy-db? #:db-type-has-views? @@ -159,6 +161,7 @@ #:*loaded-database-types* #:reload-database-types #:is-database-open + #:*db-pool-max-free-connections* ;; Large objects #:database-create-large-object @@ -391,6 +394,7 @@ #:locally-disable-sql-reader-syntax #:locally-enable-sql-reader-syntax #:restore-sql-reader-syntax-state + #:file-enable-sql-reader-syntax ;; SQL operations (operations.lisp) #:sql-query diff --git a/sql/pool.lisp b/sql/pool.lisp index 1fb0c59..38d32cd 100644 --- a/sql/pool.lisp +++ b/sql/pool.lisp @@ -16,65 +16,114 @@ (in-package #:clsql-sys) +(defparameter *db-pool-max-free-connections* 4 + "Threshold of free-connections in the pool before we disconnect a + database rather than returning it to the pool. This is really a heuristic +that should, on avg keep the free connections about this size.") + (defvar *db-pool* (make-hash-table :test #'equal)) (defvar *db-pool-lock* (make-process-lock "DB Pool lock")) (defclass conn-pool () ((connection-spec :accessor connection-spec :initarg :connection-spec) (database-type :accessor pool-database-type :initarg :pool-database-type) - (free-connections :accessor free-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)) - (all-connections :accessor all-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)) + (free-connections :accessor free-connections :initform nil) + (all-connections :accessor all-connections :initform nil) (lock :accessor conn-pool-lock - :initform (make-process-lock "Connection pool")))) - -(defun acquire-from-conn-pool (pool) - (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool") - (when (plusp (length (free-connections pool))) - (let ((pconn (vector-pop (free-connections pool)))) - ;; test if connection still valid. - ;; Currently, on supported on MySQL - (cond - ((eq :mysql (database-type pconn)) - (handler-case - (database-query "SHOW ERRORS LIMIT 1" pconn nil nil) - (error (e) - ;; we could check for error type 2006 for "SERVER GONE AWAY", - ;; but, it's safer just to disconnect the pooled conn for any error - (warn "Database connection ~S had an error when attempted to be acquired from the pool: + :initform (make-process-lock "Connection pool")))) + + +(defun acquire-from-pool (connection-spec database-type &optional pool) + "Try to find a working database connection in the pool or create a new +one if needed. This performs 1 query against the DB to ensure it's still +valid. When possible (postgres, mssql) that query will be a reset +command to put the connection back into its default state." + (unless (typep pool 'conn-pool) + (setf pool (find-or-create-connection-pool connection-spec database-type))) + (or + (loop for pconn = (with-process-lock ((conn-pool-lock pool) "Acquire") + (pop (free-connections pool))) + always pconn + thereis + ;; test if connection still valid. + ;; (e.g. db reboot -> invalid connection ) + (handler-case + (progn (database-acquire-from-conn-pool pconn) + pconn) + (sql-database-error (e) + ;; we could check for a specific error, + ;; but, it's safer just to disconnect the pooled conn for any error ? + (warn "Database connection ~S had an error while acquiring from the pool: ~S Disconnecting.~%" - pconn e) - (ignore-errors (database-disconnect pconn)) - nil) - (:no-error (res fields) - (declare (ignore res fields)) - pconn))) - (t - pconn))))) - (let ((conn (connect (connection-spec pool) - :database-type (pool-database-type pool) - :if-exists :new - :make-default nil))) - (with-process-lock ((conn-pool-lock pool) "Acquire from pool") - (vector-push-extend conn (all-connections pool)) - (setf (conn-pool conn) pool)) - conn))) - -(defun release-to-conn-pool (conn) - (let ((pool (conn-pool conn))) - (with-process-lock ((conn-pool-lock pool) "Release to pool") - (vector-push-extend conn (free-connections pool))))) + pconn e) + ;;run database disconnect to give chance for cleanup + ;;there, then remove it from the lists of connected + ;;databases. + (%pool-force-disconnect pconn) + (with-process-lock ((conn-pool-lock pool) "remove dead conn") + (setf (all-connections pool) + (delete pconn (all-connections pool)))) + nil))) + (let ((conn (connect (connection-spec pool) + :database-type (pool-database-type pool) + :if-exists :new + :make-default nil))) + (with-process-lock ((conn-pool-lock pool) "new conection") + (push conn (all-connections pool)) + (setf (conn-pool conn) pool)) + conn))) + +(defun release-to-pool (database) + "Release a database connection to the pool. The backend will have a +chance to do cleanup." + (let ((pool (conn-pool database))) + (cond + ;;We read the list of free-connections outside the lock. This + ;;should be fine as long as that list is never dealt with + ;;destructively (push and pop destructively modify the place, + ;;not the list). Multiple threads getting to this test at the + ;;same time might result in the free-connections getting + ;;longer... meh. + ((>= (length (free-connections pool)) + *db-pool-max-free-connections*) + (%pool-force-disconnect database) + (with-process-lock ((conn-pool-lock pool) "Remove extra Conn") + (setf (all-connections pool) + (delete database (all-connections pool))))) + (t + ;;let it do cleanup + (database-release-to-conn-pool database) + (with-process-lock ((conn-pool-lock pool) "Release to pool") + (push database (free-connections pool))))))) + +(defmethod database-acquire-from-conn-pool (database) + (case (database-underlying-type database) + (:postgresql + (database-execute-command "RESET ALL" database)) + (:mysql + (database-query "SHOW ERRORS LIMIT 1" database nil nil)) + (:mssql + ;; rpc escape sequence since this can't be called as a normal sp. + ;;http://msdn.microsoft.com/en-us/library/aa198358%28SQL.80%29.aspx + (database-execute-command "{rpc sp_reset_connection}" database)) + (T + (database-query "SELECT 1;" database '(integer) nil)))) + +(defmethod database-release-to-conn-pool (database) + (case (database-underlying-type database) + (:postgresql + (ignore-errors + ;;http://www.postgresql.org/docs/current/static/sql-discard.html + ;;this was introduced relatively recently, wrap in ignore-errors + ;;so that it doesn't choke older versions. + (database-execute-command "DISCARD ALL" database))))) (defun clear-conn-pool (pool) (with-process-lock ((conn-pool-lock pool) "Clear pool") - (loop for conn across (all-connections pool) - do (setf (conn-pool conn) nil) - ;; disconnect may error if remote side closed connection - (ignore-errors (disconnect :database conn))) - (setf (fill-pointer (free-connections pool)) 0) - (setf (fill-pointer (all-connections pool)) 0)) + (mapc #'%pool-force-disconnect (all-connections pool)) + (setf (all-connections pool) nil + (free-connections pool) nil)) nil) (defun find-or-create-connection-pool (connection-spec database-type) @@ -82,33 +131,33 @@ Disconnecting.~%" if not found" (with-process-lock (*db-pool-lock* "Find-or-create connection") (let* ((key (list connection-spec database-type)) - (conn-pool (gethash key *db-pool*))) + (conn-pool (gethash key *db-pool*))) (unless conn-pool - (setq conn-pool (make-instance 'conn-pool - :connection-spec connection-spec - :pool-database-type database-type)) - (setf (gethash key *db-pool*) conn-pool)) + (setq conn-pool (make-instance 'conn-pool + :connection-spec connection-spec + :pool-database-type database-type)) + (setf (gethash key *db-pool*) conn-pool)) conn-pool))) -(defun acquire-from-pool (connection-spec database-type &optional pool) - (unless (typep pool 'conn-pool) - (setf pool (find-or-create-connection-pool connection-spec database-type))) - (acquire-from-conn-pool pool)) - -(defun release-to-pool (database) - (release-to-conn-pool database)) - (defun disconnect-pooled (&optional clear) - "Disconnects all connections in the pool." + "Disconnects all connections in the pool. When clear, also deletes +the pool objects." (with-process-lock (*db-pool-lock* "Disconnect pooled") (maphash #'(lambda (key conn-pool) - (declare (ignore key)) - (clear-conn-pool conn-pool)) + (declare (ignore key)) + (clear-conn-pool conn-pool)) *db-pool*) (when clear (clrhash *db-pool*))) t) +(defun %pool-force-disconnect (database) + "Force disconnection of a connection from the pool." + ;;so it isn't just returned to pool + (setf (conn-pool database) nil) + ;; disconnect may error if remote side closed connection + (ignore-errors (disconnect :database database))) + ;(defun pool-start-sql-recording (pool &key (types :command)) ; "Start all stream in the pool recording actions of TYPES" ; (dolist (con (pool-connections pool)) diff --git a/sql/syntax.lisp b/sql/syntax.lisp index 1aec1ca..7e1906b 100644 --- a/sql/syntax.lisp +++ b/sql/syntax.lisp @@ -64,6 +64,15 @@ the current syntax state." '(eval-when (:compile-toplevel :load-toplevel :execute) (%enable-sql-reader-syntax))) +(defmacro file-enable-sql-reader-syntax () + "Turns on the SQL reader syntax for the rest of the file. +The CL spec says that when finished loading a file the original +*readtable* is restored. clhs COMPILE-FILE" + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *readtable* (copy-readtable)) + (set-macro-character *sql-macro-open-char* #'sql-reader-open) + (set-macro-character *sql-macro-close-char* (get-macro-character #\))))) + (defun %enable-sql-reader-syntax () (unless *original-readtable* (setf *original-readtable* *readtable*