sql/recording.lisp

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