r8942: add :query to sql recording, support describe-table

diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp
index 61a932e5ad02df135fc3e6c0687c4c6c962ca0d8..64fdb44038d4741eecb6b5c7ceb27e5768067e66 100644 (file)
--- 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 9888ba1e3e70bb4a11e82b9a01df13740db6f0d9..e403fb6b7daefc5b89ed9981560260eb75867bcb 100644 (file)
--- 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 78df75df9096b9c502a900f2024c55b4059df4ae..819a8981a7e8806b6f06a2b9404928fa9111f919 100644 (file)
--- 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 5f0f495815652c34b39fa95d219b8849546d11cc..2f83bf449e27e58b4d3c9bdff7be9e5e52f3ffc6 100644 (file)
--- 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 236705da1ad70cfb7c842fa73bf27613e09c7dbd..da03282c811ce3e644b1adbd7aed8689fdd81aa3 100644 (file)
--- 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 98ada92fca4932c6658100063ca9d59d78d2f623..8997c30c9e5798b06fd6c4b1ef42f8663edcf902 100644 (file)
--- 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)))))