From d8cc56b3f55e00fda2afffe8dae7d158bf33e2d8 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 11 Apr 2004 10:15:14 +0000 Subject: [PATCH] r8942: add :query to sql recording, support describe-table --- base/basic-sql.lisp | 12 +++-- base/package.lisp | 21 +++++--- base/pool.lisp | 35 ++++++++----- base/recording.lisp | 113 ++++++++++++++++++++++++++---------------- base/transaction.lisp | 11 +--- base/utils.lisp | 7 +++ 6 files changed, 123 insertions(+), 76 deletions(-) diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp index 61a932e..64fdb44 100644 --- a/base/basic-sql.lisp +++ b/base/basic-sql.lisp @@ -31,14 +31,14 @@ that expression and a list of field names selected in sql-exp.")) (defmethod query ((query-expression string) &key (database *default-database*) (result-types nil) (flatp nil)) - (record-sql-command query-expression database) + (record-sql-action query-expression :query database) (let* ((res (database-query query-expression database result-types)) (res (if (and flatp (= (length (slot-value query-expression 'selections)) 1)) (mapcar #'car res) res))) - (record-sql-result res database) + (record-sql-action res :result database) res)) ;;; Execute @@ -54,12 +54,16 @@ pair.")) (defmethod execute-command ((sql-expression string) &key (database *default-database*)) - (record-sql-command sql-expression database) + (record-sql-action sql-expression :command database) (let ((res (database-execute-command sql-expression database))) - (record-sql-result res database)) + (record-sql-action res :result database)) (values)) +(defun describe-table (table &key (database *default-database*)) + "Return list of 2-element lists containing table name and type." + (database-describe-table database table)) + (defmacro do-query (((&rest args) query-expression &key (database '*default-database*) (result-types nil)) &body body) diff --git a/base/package.lisp b/base/package.lisp index 9888ba1..e403fb6 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -34,6 +34,7 @@ #:database-initialize-database-type #:database-connect #:database-disconnect + #:database-reconnect #:database-query #:database-execute-command #:database-query-result-set @@ -42,7 +43,8 @@ #:database-create #:database-destroy #:database-probe - + #:database-describe-table + #:database-list-tables #:database-list-attributes #:database-attribute-type @@ -57,8 +59,6 @@ #:database-list-indexes #:database-list-views - ;; Support for pooled connections - #:database-type ;; Large objects (Marc B) #:database-create-large-object @@ -67,6 +67,10 @@ #:database-delete-large-object #:command-output + #:make-process-lock + #:with-process-lock + #:connection-spec + #:ensure-keyword ;; Shared exports for re-export by CLSQL-BASE . @@ -113,9 +117,9 @@ #:connected-databases #:database #:database-name - #:closed-database #:find-database #:database-name-from-spec + #:is-database-open ;; accessors for database class #:name @@ -125,8 +129,11 @@ #:conn-pool #:command-recording-stream #:result-recording-stream + #:query-recording-stream #:view-classes - + #:database-type + #:database-state + ;; utils.lisp #:number-to-sql-string #:float-to-sql-string @@ -207,8 +214,7 @@ #:week-containing ;; recording.lisp -- SQL I/O Recording - #:record-sql-comand - #:record-sql-result + #:record-sql-action #:add-sql-stream ; recording xx #:delete-sql-stream ; recording xx #:list-sql-streams ; recording xx @@ -244,6 +250,7 @@ #:delete-large-object #:do-query #:map-query + #:describe-table ;; Transactions #:with-transaction diff --git a/base/pool.lisp b/base/pool.lisp index 78df75d..819a898 100644 --- a/base/pool.lisp +++ b/base/pool.lisp @@ -20,29 +20,38 @@ (defun make-process-lock (name) #+allegro (mp:make-process-lock :name name) - #+scl (thread:make-lock name) + #+cmu (mp:make-lock :name name) #+lispworks (mp:make-lock :name name) - #-(or allegro scl lispworks) (declare (ignore name)) - #-(or allegro scl lispworks) nil) + #+openmcl (ccl:make-lock :name name) + #+sb-thread (sb-thread:make-mutex :name name) + #+scl (thread:make-lock name) + #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name)) + #-(or allegro cmu lispworks openmcl sb-thread scl) nil) (defmacro with-process-lock ((lock desc) &body body) - #+scl `(thread:with-lock-held (,lock ,desc) ,@body) - #+(or allegro lispworks) + #+(or cmu allegro lispworks openmcl sb-thread) (declare (ignore desc)) - #+(or allegro lispworks) + #+(or allegro cmu lispworks openmcl sb-thread) (let ((l (gensym))) `(let ((,l ,lock)) - #+allegro (mp:with-process-lock (,l) ,@body) - #+lispworks (mp:with-lock (,l) ,@body))) - #-(or scl allegro lispworks) (declare (ignore lock desc)) - #-(or scl allegro lispworks) `(progn ,@body)) + #+allegro (mp:with-process-lock (,l) ,@body) + #+cmu `(mp:with-lock-held (,lock) ,@body) + #+openmcl (ccl:with-lock-grabbed (,lock) ,@body) + #+lispworks (mp:with-lock (,l) ,@body) + #+sb-thread (sb-thread:with-recursive-lock (,lock) ,@body) + )) + + #+scl `(thread:with-lock-held (,lock ,desc) ,@body) + + #-(or cmu allegro lispworks openmcl sb-thread scl) (declare (ignore lock desc)) + #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body)) (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 database-type :initarg :database-type) + (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 @@ -55,7 +64,7 @@ (and (plusp (length (free-connections pool))) (vector-pop (free-connections pool)))) (let ((conn (connect (connection-spec pool) - :database-type (database-type pool) + :database-type (pool-database-type pool) :if-exists :new))) (with-process-lock ((conn-pool-lock pool) "Acquire from pool") (vector-push-extend conn (all-connections pool)) @@ -85,7 +94,7 @@ if not found" (unless conn-pool (setq conn-pool (make-instance 'conn-pool :connection-spec connection-spec - :database-type database-type)) + :pool-database-type database-type)) (setf (gethash key *db-pool*) conn-pool)) conn-pool))) diff --git a/base/recording.lisp b/base/recording.lisp index 5f0f495..2f83bf4 100644 --- a/base/recording.lisp +++ b/base/recording.lisp @@ -20,131 +20,160 @@ broadcast stream is just *STANDARD-OUTPUT* but this can be modified using ADD-SQL-STREAM or DELETE-SQL-STREAM. TYPE determines whether SQL command or result traffic is recorded, or both. It must be either -:commands, :results or :both, and defaults to :commands. DATABASE -defaults to *default-database*." - (when (or (eq type :both) (eq type :commands)) +:commands, :results, :query, :both, or :all, and defaults to +:commands. DATABASE defaults to *default-database*." + (when (in type :all :both :commands) (setf (command-recording-stream database) (make-broadcast-stream *standard-output*))) - (when (or (eq type :both) (eq type :results)) + (when (in type :all :both :results) (setf (result-recording-stream database) (make-broadcast-stream *standard-output*))) + (when (in type :all :query) + (setf (query-recording-stream database) + (make-broadcast-stream + *standard-output*))) (values)) (defun stop-sql-recording (&key (type :commands) (database *default-database*)) "Stops recording of SQL command or result traffic. TYPE determines whether to stop SQL command or result traffic, or both. It must be -either :commands, :results or :both, defaulting to :commands. DATABASE +either :commands, :results, :both, or :all, defaulting to :commands. DATABASE defaults to *default-database*." - (when (or (eq type :both) (eq type :commands)) + (when (in type :all :both :commands) (setf (command-recording-stream database) nil)) - (when (or (eq type :both) (eq type :results)) + (when (in type :all :both :results) (setf (result-recording-stream database) nil)) + (when (in type :all :query) + (setf (query-recording-stream database) nil)) (values)) (defun sql-recording-p (&key (type :commands) (database *default-database*)) "Returns t if recording of TYPE of SQL interaction specified is -enabled. TYPE must be either :commands, :results, :both or :either. -DATABASE defaults to *default-database*." +enabled. TYPE must be either :commands, :results, :query, :all, +:both, :either, or :any. DATABASE defaults to *default-database*." (when (or (and (eq type :commands) (command-recording-stream database)) (and (eq type :results) (result-recording-stream database)) + (and (eq type :all) + (result-recording-stream database) + (query-recording-stream database) + (command-recording-stream database)) (and (eq type :both) (result-recording-stream database) (command-recording-stream database)) (and (eq type :either) (or (result-recording-stream database) - (command-recording-stream database)))) + (command-recording-stream database))) + (and (eq type :any) + (or (result-recording-stream database) + (command-recording-stream database) + (query-recording-stream database)))) t)) (defun add-sql-stream (stream &key (type :commands) (database *default-database*)) "Add the given STREAM as a component stream for the recording broadcast stream for the given SQL interaction TYPE. TYPE must be -either :commands, :results, or :both, defaulting to :commands. -DATABASE defaults to *default-database*." - (when (or (eq type :both) (eq type :commands)) +either :commands, :results, :query, :all, or :both, defaulting to +:commands. DATABASE defaults to *default-database*." + (when (in type :all :both :commands) (unless (member stream (list-sql-streams :type :commands :database database)) (setf (command-recording-stream database) (apply #'make-broadcast-stream (cons stream (list-sql-streams :type :commands :database database)))))) - (when (or (eq type :both) (eq type :results)) + (when (in type :all :both :results) (unless (member stream (list-sql-streams :type :results :database database)) (setf (result-recording-stream database) (apply #'make-broadcast-stream (cons stream (list-sql-streams :type :results :database database)))))) + (when (in type :all :query) + (unless (member stream (list-sql-streams :type :query :database database)) + (setf (query-recording-stream database) + (apply #'make-broadcast-stream + (cons stream (list-sql-streams :type :query + :database database)))))) stream) (defun delete-sql-stream (stream &key (type :commands) (database *default-database*)) "Removes the given STREAM from the recording broadcast stream for the given TYPE of SQL interaction. TYPE must be either :commands, -:results, or :both, defaulting to :commands. DATABASE defaults to -*default-database*." - (when (or (eq type :both) (eq type :commands)) +:results, :query, :both, or :all, defaulting to :commands. DATABASE +defaults to *default-database*." + (when (in type :all :both :commands) (setf (command-recording-stream database) (apply #'make-broadcast-stream (remove stream (list-sql-streams :type :commands :database database))))) - (when (or (eq type :both) (eq type :results)) + (when (in type :all :both :results) (setf (result-recording-stream database) (apply #'make-broadcast-stream (remove stream (list-sql-streams :type :results :database database))))) + (when (in type :all :query) + (setf (query-recording-stream database) + (apply #'make-broadcast-stream + (remove stream (list-sql-streams :type :commands + :database database))))) stream) (defun list-sql-streams (&key (type :commands) (database *default-database*)) "Returns the set of streams which the recording broadcast stream send SQL interactions of the given TYPE sends data. TYPE must be -either :commands, :results, or :both, defaulting to :commands. +either :commands, :results, :query, :both, or :all, defaulting to :commands. DATABASE defaults to *default-database*." (let ((crs (command-recording-stream database)) + (qrs (query-recording-stream database)) (rrs (result-recording-stream database))) (cond ((eq type :commands) (when crs (broadcast-stream-streams crs))) ((eq type :results) (when rrs (broadcast-stream-streams rrs))) + ((eq type :query) + (when qrs (broadcast-stream-streams qrs))) ((eq type :both) (append (when crs (broadcast-stream-streams crs)) (when rrs (broadcast-stream-streams rrs)))) + ((eq type :all) + (append (when crs (broadcast-stream-streams crs)) + (when rrs (broadcast-stream-streams rrs)) + (when qrs (broadcast-stream-streams qrs)))) (t (error "Unknown recording type. ~A" type))))) (defun sql-stream (&key (type :commands) (database *default-database*)) "Returns the broadcast streams used for recording SQL commands or -results traffic. TYPE must be either :commands or :results defaulting +results traffic. TYPE must be either :commands, :query, or :results defaulting to :commands while DATABASE defaults to *default-database*." (cond ((eq type :commands) (command-recording-stream database)) ((eq type :results) (result-recording-stream database)) + ((eq type :query) + (query-recording-stream database)) (t (error "Unknown recording type. ~A" type)))) -(defun record-sql-command (expr database) - (if database - (with-slots (command-recording-stream) - database - (if command-recording-stream - (format command-recording-stream "~&;; ~A ~A => ~A~%" - (iso-timestring (get-time)) - (database-name database) - expr))))) - -(defun record-sql-result (res database) - (if database - (with-slots (result-recording-stream) - database - (if result-recording-stream - (format result-recording-stream "~&;; ~A ~A <= ~A~%" - (iso-timestring (get-time)) - (database-name database) - res))))) - - - +(defun record-sql-action (expr type database) + (unless database + (return-from record-sql-action)) + (with-slots (command-recording-stream + query-recording-stream + result-recording-stream) + database + (let ((stream + (ecase type + (:command command-recording-stream) + (:query query-recording-stream) + (:result result-recording-stream)))) + (when stream + (format stream ";; ~A ~A => ~A~%" + (iso-timestring (get-time)) + (database-name database) + expr))))) diff --git a/base/transaction.lisp b/base/transaction.lisp index 236705d..da03282 100644 --- a/base/transaction.lisp +++ b/base/transaction.lisp @@ -32,11 +32,8 @@ (when (transaction database) (push rollback-hook (rollback-hooks (transaction database))))) -(defmethod database-start-transaction ((database closed-database)) - (signal-closed-database-error database)) - (defmethod database-start-transaction (database) - (unless database (error 'clsql-nodb-error)) + (unless database (error 'clsql-no-database-error)) (unless (transaction database) (setf (transaction database) (make-instance 'transaction))) (when (= (incf (transaction-level database) 1)) @@ -46,9 +43,6 @@ (transaction-status transaction) nil) (execute-command "BEGIN" :database database)))) -(defmethod database-commit-transaction ((database closed-database)) - (signal-closed-database-error database)) - (defmethod database-commit-transaction (database) (if (> (transaction-level database) 0) (when (zerop (decf (transaction-level database))) @@ -58,9 +52,6 @@ :format-control "Cannot commit transaction against ~A because there is no transaction in progress." :format-arguments (list database)))) -(defmethod database-abort-transaction ((database closed-database)) - (signal-closed-database-error database)) - (defmethod database-abort-transaction (database) (if (> (transaction-level database) 0) (when (zerop (decf (transaction-level database))) diff --git a/base/utils.lisp b/base/utils.lisp index 98ada92..8997c30 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -231,3 +231,10 @@ returns (VALUES string-output error-output exit-status)" (keyword name) (string (nth-value 0 (intern (string-default-case name) :keyword))) (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) + +;; From KMRCL +(defmacro in (obj &rest choices) + (let ((insym (gensym))) + `(let ((,insym ,obj)) + (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c)) + choices))))) -- 2.34.1