sql/recording.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; CLSQL broadcast streams which can be used to monitor the
   7 ;;;; flow of commands to, and results from, a database.
   8 ;;;;
   9 ;;;; This file is part of CLSQL.
  10 ;;;;
  11 ;;;; CLSQL users are granted the rights to distribute and use this software
  12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  14 ;;;; *************************************************************************
  15
  16 (in-package #:clsql-sys)
  17
  18 (defun start-sql-recording (&key (type :commands) (database *default-database*))
  19   "Starts recording of SQL commands sent to and/or results
  20 returned from DATABASE which defaults to *DEFAULT-DATABASE*. The
  21 SQL is output on one or more broadcast streams, initially just
  22 *STANDARD-OUTPUT*, and the functions ADD-SQL-STREAM and
  23 DELETE-SQL-STREAM may be used to add or delete command or result
  24 recording streams. The default value of TYPE is :commands which
  25 means that SQL commands sent to DATABASE are recorded. If TYPE
  26 is :results then SQL results returned from DATABASE are
  27 recorded. Both commands and results may be recorded by passing
  28 TYPE value of :both."
  29   (when (or (eq type :both) (eq type :commands))
  30     (setf (command-recording-stream database)
  31           (make-broadcast-stream *standard-output*)))
  32   (when (or (eq type :both) (eq type :results))
  33     (setf (result-recording-stream database)
  34           (make-broadcast-stream *standard-output*)))
  35   (values))
  36
  37 (defun stop-sql-recording (&key (type :commands) (database *default-database*))
  38   "Stops recording of SQL commands sent to and/or results
  39 returned from DATABASE which defaults to *DEFAULT-DATABASE*. The
  40 default value of TYPE is :commands which means that SQL commands
  41 sent to DATABASE will no longer be recorded. If TYPE is :results
  42 then SQL results returned from DATABASE will no longer be
  43 recorded. Recording may be stopped for both commands and results
  44 by passing TYPE value of :both."
  45   (when (or (eq type :both) (eq type :commands))
  46     (setf (command-recording-stream database) nil))
  47   (when (or (eq type :both) (eq type :results))
  48     (setf (result-recording-stream database) nil))
  49   (values))
  50
  51 (defun sql-recording-p (&key (type :commands) (database *default-database*))
  52   "Predicate to test whether the SQL recording specified by TYPE
  53 is currently enabled for DATABASE which defaults to *DEFAULT-DATABASE*.
  54 TYPE may be one of :commands, :results, :both or :either, defaulting to
  55 :commands, otherwise nil is returned."
  56   (when (or (and (eq type :commands)
  57                  (command-recording-stream database))
  58             (and (eq type :results)
  59                  (result-recording-stream database))
  60             (and (eq type :both)
  61                  (result-recording-stream database)
  62                  (command-recording-stream database))
  63             (and (eq type :either)
  64                  (or (result-recording-stream database)
  65                      (command-recording-stream database))))
  66     t))
  67
  68 (defun add-sql-stream (stream &key (type :commands)
  69                               (database *default-database*))
  70   "Adds the supplied stream STREAM (or T for *standard-output*)
  71 as a component of the recording broadcast stream for the SQL
  72 recording type specified by TYPE on DATABASE which defaults to
  73 *DEFAULT-DATABASE*. TYPE must be one of :commands, :results,
  74 or :both, defaulting to :commands, depending on whether the
  75 stream is to be added for recording SQL commands, results or
  76 both."
  77   (when (or (eq type :both) (eq type :commands))
  78     (unless (member stream
  79                     (list-sql-streams :type :commands :database database))
  80       (setf (command-recording-stream database)
  81             (apply #'make-broadcast-stream
  82                    (cons stream (list-sql-streams :type :commands
  83                                                   :database database))))))
  84   (when (or (eq type :both) (eq type :results))
  85     (unless (member stream (list-sql-streams :type :results :database database))
  86       (setf (result-recording-stream database)
  87             (apply #'make-broadcast-stream
  88                    (cons stream (list-sql-streams :type :results
  89                                                   :database database))))))
  90   stream)
  91
  92 (defun delete-sql-stream (stream &key (type :commands)
  93                                  (database *default-database*))
  94  "Removes the supplied stream STREAM from the recording broadcast
  95 stream for the SQL recording type specified by TYPE on DATABASE
  96 which defaults to *DEFAULT-DATABASE*. TYPE must be one
  97 of :commands, :results, or :both, defaulting to :commands,
  98 depending on whether the stream is to be added for recording SQL
  99 commands, results or both."
 100   (when (or (eq type :both) (eq type :commands))
 101     (setf (command-recording-stream database)
 102           (apply #'make-broadcast-stream
 103                  (remove stream (list-sql-streams :type :commands
 104                                                   :database database)))))
 105   (when (or (eq type :both) (eq type :results))
 106     (setf (result-recording-stream database)
 107           (apply #'make-broadcast-stream
 108                  (remove stream (list-sql-streams :type :results
 109                                                   :database database)))))
 110   stream)
 111
 112 (defun list-sql-streams (&key (type :commands) (database *default-database*))
 113   "Returns the list of component streams for the broadcast stream
 114 recording SQL commands sent to and/or results returned from
 115 DATABASE which defaults to *DEFAULT-DATABASE*. TYPE must be one
 116 of :commands, :results, or :both, defaulting to :commands, and
 117 determines whether the listed streams contain those recording SQL
 118 commands, results or both."
 119   (let ((crs (command-recording-stream database))
 120         (rrs (result-recording-stream database)))
 121     (cond
 122       ((eq type :commands)
 123        (when crs (broadcast-stream-streams crs)))
 124       ((eq type :results)
 125        (when rrs (broadcast-stream-streams rrs)))
 126       ((eq type :both)
 127        (append (when crs (broadcast-stream-streams crs))
 128                (when rrs (broadcast-stream-streams rrs))))
 129       (t
 130        (error "Unknown recording type. ~A" type)))))
 131
 132 (defun sql-stream (&key (type :commands) (database *default-database*))
 133   "Returns the broadcast stream used for recording SQL commands
 134 sent to or results returned from DATABASE which defaults to
 135 *DEFAULT-DATABASE*. TYPE must be one of :commands or :results,
 136 defaulting to :commands, and determines whether the stream
 137 returned is that used for recording SQL commands or results."
 138   (cond
 139     ((eq type :commands)
 140      (command-recording-stream database))
 141     ((eq type :results)
 142      (result-recording-stream database))
 143     (t
 144      (error "Unknown recording type. ~A" type))))
 145
 146 (defun record-sql-command (expr database)
 147   (when database
 148     (with-slots (command-recording-stream)
 149         database
 150       (when command-recording-stream
 151         (format command-recording-stream "~&;; ~A ~A => ~A~%"
 152                 (iso-timestring (get-time))
 153                 (database-name database)
 154                 expr)))))
 155
 156 (defun record-sql-result (res database)
 157   (when database
 158     (with-slots (result-recording-stream)
 159         database
 160       (when result-recording-stream
 161         (format result-recording-stream "~&;; ~A ~A <= ~A~%"
 162                 (iso-timestring (get-time))
 163                 (database-name database)
 164                 res)))))
 165
 166
 167