base/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-base)
  17
  18 (defun start-sql-recording (&key (type :commands) (database *default-database*))
  19   "Begin recording SQL command or result traffic. By default the
  20 broadcast stream is just *STANDARD-OUTPUT* but this can be modified
  21 using ADD-SQL-STREAM or DELETE-SQL-STREAM. TYPE determines whether SQL
  22 command or result traffic is recorded, or both. It must be either
  23 :commands, :results, :query, :both, or :all, and defaults to
  24 :commands. DATABASE defaults to *default-database*."
  25   (when (in type :all :both :commands)
  26     (setf (command-recording-stream database)
  27           (make-broadcast-stream *standard-output*)))
  28   (when (in type :all :both :results)
  29     (setf (result-recording-stream database)
  30           (make-broadcast-stream *standard-output*)))
  31   (when (in type :all :query)
  32     (setf (query-recording-stream database)
  33           (make-broadcast-stream
  34            *standard-output*)))
  35   (values))
  36
  37 (defun stop-sql-recording (&key (type :commands) (database *default-database*))
  38   "Stops recording of SQL command or result traffic.  TYPE determines
  39 whether to stop SQL command or result traffic, or both.  It must be
  40 either :commands, :results, :both, or :all, defaulting to :commands. DATABASE
  41 defaults to *default-database*."
  42   (when (in type :all :both :commands)
  43     (setf (command-recording-stream database) nil))
  44   (when (in type :all :both :results)
  45     (setf (result-recording-stream database) nil))
  46   (when (in type :all :query)
  47     (setf (query-recording-stream database) nil))
  48   (values))
  49
  50 (defun sql-recording-p (&key (type :commands) (database *default-database*))
  51   "Returns t if recording of TYPE of SQL interaction specified is
  52 enabled.  TYPE must be either :commands, :results, :query, :all,
  53 :both, :either, or :any.  DATABASE defaults to *default-database*."
  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 :all)
  59                  (result-recording-stream database)
  60                  (query-recording-stream database)
  61                  (command-recording-stream database))
  62             (and (eq type :both)
  63                  (result-recording-stream database)
  64                  (command-recording-stream database))
  65             (and (eq type :either)
  66                  (or (result-recording-stream database)
  67                      (command-recording-stream database)))
  68             (and (eq type :any)
  69                  (or (result-recording-stream database)
  70                      (command-recording-stream database)
  71                      (query-recording-stream database))))
  72     t))
  73
  74 (defun add-sql-stream (stream &key (type :commands)
  75                               (database *default-database*))
  76   "Add the given STREAM as a component stream for the recording
  77 broadcast stream for the given SQL interaction TYPE.  TYPE must be
  78 either :commands, :results, :query, :all, or :both, defaulting to
  79 :commands.  DATABASE defaults to *default-database*."
  80   (when (in type :all :both :commands)
  81     (unless (member stream
  82                     (list-sql-streams :type :commands :database database))
  83       (setf (command-recording-stream database)
  84             (apply #'make-broadcast-stream
  85                    (cons stream (list-sql-streams :type :commands
  86                                                   :database database))))))
  87   (when (in type :all :both :results)
  88     (unless (member stream (list-sql-streams :type :results :database database))
  89       (setf (result-recording-stream database)
  90             (apply #'make-broadcast-stream
  91                    (cons stream (list-sql-streams :type :results
  92                                                   :database database))))))
  93   (when (in type :all :query)
  94     (unless (member stream (list-sql-streams :type :query :database database))
  95       (setf (query-recording-stream database)
  96             (apply #'make-broadcast-stream
  97                    (cons stream (list-sql-streams :type :query
  98                                                   :database database))))))
  99   stream)
 100
 101 (defun delete-sql-stream (stream &key (type :commands)
 102                                  (database *default-database*))
 103   "Removes the given STREAM from the recording broadcast stream for
 104 the given TYPE of SQL interaction.  TYPE must be either :commands,
 105 :results, :query, :both, or :all, defaulting to :commands.  DATABASE
 106 defaults to *default-database*."
 107   (when (in type :all :both :commands)
 108     (setf (command-recording-stream database)
 109           (apply #'make-broadcast-stream
 110                  (remove stream (list-sql-streams :type :commands
 111                                                   :database database)))))
 112   (when (in type :all :both :results)
 113     (setf (result-recording-stream database)
 114           (apply #'make-broadcast-stream
 115                  (remove stream (list-sql-streams :type :results
 116                                                   :database database)))))
 117   (when (in type :all :query)
 118     (setf (query-recording-stream database)
 119           (apply #'make-broadcast-stream
 120                  (remove stream (list-sql-streams :type :commands
 121                                                   :database database)))))
 122   stream)
 123
 124 (defun list-sql-streams (&key (type :commands) (database *default-database*))
 125   "Returns the set of streams which the recording broadcast stream
 126 send SQL interactions of the given TYPE sends data. TYPE must be
 127 either :commands, :results, :query, :both, or :all, defaulting to :commands.
 128 DATABASE defaults to *default-database*."
 129   (let ((crs (command-recording-stream database))
 130         (qrs (query-recording-stream database))
 131         (rrs (result-recording-stream database)))
 132     (cond
 133       ((eq type :commands)
 134        (when crs (broadcast-stream-streams crs)))
 135       ((eq type :results)
 136        (when rrs (broadcast-stream-streams rrs)))
 137       ((eq type :query)
 138        (when qrs (broadcast-stream-streams qrs)))
 139       ((eq type :both)
 140        (append (when crs (broadcast-stream-streams crs))
 141                (when rrs (broadcast-stream-streams rrs))))
 142       ((eq type :all)
 143        (append (when crs (broadcast-stream-streams crs))
 144                (when rrs (broadcast-stream-streams rrs))
 145                (when qrs (broadcast-stream-streams qrs))))
 146       (t
 147        (error "Unknown recording type. ~A" type)))))
 148
 149 (defun sql-stream (&key (type :commands) (database *default-database*))
 150   "Returns the broadcast streams used for recording SQL commands or
 151 results traffic. TYPE must be either :commands, :query, or :results defaulting
 152 to :commands while DATABASE defaults to *default-database*."
 153   (cond
 154     ((eq type :commands)
 155      (command-recording-stream database))
 156     ((eq type :results)
 157      (result-recording-stream database))
 158     ((eq type :query)
 159      (query-recording-stream database))
 160     (t
 161      (error "Unknown recording type. ~A" type))))
 162
 163 (defun record-sql-action (expr type database)
 164   (unless database
 165     (return-from record-sql-action))
 166   (with-slots (command-recording-stream
 167                query-recording-stream
 168                result-recording-stream)
 169       database
 170     (let ((stream
 171            (ecase type
 172              (:command command-recording-stream)
 173              (:query query-recording-stream)
 174              (:result result-recording-stream))))
 175       (when stream
 176         (format stream ";; ~A ~A => ~A~%"
 177                 (iso-timestring (get-time))
 178                               (database-name database)
 179                               expr)))))