lib/DBIx/Class/Storage/Statistics.pm

   1 package DBIx::Class::Storage::Statistics;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::_Util qw(sigwarn_silencer qsub);
   7 use IO::Handle ();
   8 use Moo;
   9 extends 'DBIx::Class';
  10 use namespace::clean;
  11
  12 =head1 NAME
  13
  14 DBIx::Class::Storage::Statistics - SQL Statistics
  15
  16 =head1 SYNOPSIS
  17
  18 =head1 DESCRIPTION
  19
  20 This class is called by DBIx::Class::Storage::DBI as a means of collecting
  21 statistics on its actions.  Using this class alone merely prints the SQL
  22 executed, the fact that it completes and begin/end notification for
  23 transactions.
  24
  25 To really use this class you should subclass it and create your own method
  26 for collecting the statistics as discussed in L<DBIx::Class::Manual::Cookbook>.
  27
  28 =head1 METHODS
  29
  30 =head2 new
  31
  32 Returns a new L<DBIx::Class::Storage::Statistics> object.
  33
  34 =head2 debugfh
  35
  36 Sets or retrieves the filehandle used for trace/debug output.  This should
  37 be an L<IO::Handle> compatible object (only the
  38 L<< print|IO::Handle/METHODS >> method is used). By
  39 default it is initially set to STDERR - although see discussion of the
  40 L<DBIC_TRACE|DBIx::Class::Storage/DBIC_TRACE> environment variable.
  41
  42 Invoked as a getter it will lazily open a filehandle and set it to
  43 L<< autoflush|perlvar/HANDLE->autoflush( EXPR ) >> (if one is not
  44 already set).
  45
  46 =cut
  47
  48 # FIXME - there ought to be a way to fold this into _debugfh itself
  49 # having the undef re-trigger the builder (or better yet a default
  50 # which can be folded in as a qsub)
  51 sub debugfh {
  52   my $self = shift;
  53
  54   return $self->_debugfh(@_) if @_;
  55   $self->_debugfh || $self->_build_debugfh;
  56 }
  57
  58 has _debugfh => (
  59   is => 'rw',
  60   lazy => 1,
  61   trigger => qsub '$_[0]->_defaulted_to_stderr(undef)',
  62   builder => '_build_debugfh',
  63 );
  64
  65 sub _build_debugfh {
  66   my $fh;
  67
  68   my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE};
  69
  70   if (defined($debug_env) and ($debug_env =~ /=(.+)$/)) {
  71     open ($fh, '>>', $1)
  72       or die("Cannot open trace file $1: $!\n");
  73   }
  74   else {
  75     open ($fh, '>&STDERR')
  76       or die("Duplication of STDERR for debug output failed (perhaps your STDERR is closed?): $!\n");
  77     $_[0]->_defaulted_to_stderr(1);
  78   }
  79
  80   $fh->autoflush(1);
  81
  82   $fh;
  83 }
  84
  85 has [qw(_defaulted_to_stderr silence callback)] => (
  86   is => 'rw',
  87 );
  88
  89 =head2 print
  90
  91 Prints the specified string to our debugging filehandle.  Provided to save our
  92 methods the worry of how to display the message.
  93
  94 =cut
  95 sub print {
  96   my ($self, $msg) = @_;
  97
  98   return if $self->silence;
  99
 100   my $fh = $self->debugfh;
 101
 102   # not using 'no warnings' here because all of this can change at runtime
 103   local $SIG{__WARN__} = sigwarn_silencer(qr/^Wide character in print/)
 104     if $self->_defaulted_to_stderr;
 105
 106   $fh->print($msg);
 107 }
 108
 109 =head2 silence
 110
 111 Turn off all output if set to true.
 112
 113 =head2 txn_begin
 114
 115 Called when a transaction begins.
 116
 117 =cut
 118 sub txn_begin {
 119   my $self = shift;
 120
 121   return if $self->callback;
 122
 123   $self->print("BEGIN WORK\n");
 124 }
 125
 126 =head2 txn_rollback
 127
 128 Called when a transaction is rolled back.
 129
 130 =cut
 131 sub txn_rollback {
 132   my $self = shift;
 133
 134   return if $self->callback;
 135
 136   $self->print("ROLLBACK\n");
 137 }
 138
 139 =head2 txn_commit
 140
 141 Called when a transaction is committed.
 142
 143 =cut
 144 sub txn_commit {
 145   my $self = shift;
 146
 147   return if $self->callback;
 148
 149   $self->print("COMMIT\n");
 150 }
 151
 152 =head2 svp_begin
 153
 154 Called when a savepoint is created.
 155
 156 =cut
 157 sub svp_begin {
 158   my ($self, $name) = @_;
 159
 160   return if $self->callback;
 161
 162   $self->print("SAVEPOINT $name\n");
 163 }
 164
 165 =head2 svp_release
 166
 167 Called when a savepoint is released.
 168
 169 =cut
 170 sub svp_release {
 171   my ($self, $name) = @_;
 172
 173   return if $self->callback;
 174
 175   $self->print("RELEASE SAVEPOINT $name\n");
 176 }
 177
 178 =head2 svp_rollback
 179
 180 Called when rolling back to a savepoint.
 181
 182 =cut
 183 sub svp_rollback {
 184   my ($self, $name) = @_;
 185
 186   return if $self->callback;
 187
 188   $self->print("ROLLBACK TO SAVEPOINT $name\n");
 189 }
 190
 191 =head2 query_start
 192
 193 Called before a query is executed.  The first argument is the SQL string being
 194 executed and subsequent arguments are the parameters used for the query.
 195
 196 =cut
 197 sub query_start {
 198   my ($self, $string, @bind) = @_;
 199
 200   my $message = "$string: ".join(', ', @bind)."\n";
 201
 202   if(defined($self->callback)) {
 203     $string =~ m/^(\w+)/;
 204     $self->callback->($1, $message);
 205     return;
 206   }
 207
 208   $self->print($message);
 209 }
 210
 211 =head2 query_end
 212
 213 Called when a query finishes executing.  Has the same arguments as query_start.
 214
 215 =cut
 216
 217 sub query_end {
 218   my ($self, $string) = @_;
 219 }
 220
 221 =head1 FURTHER QUESTIONS?
 222
 223 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 224
 225 =head1 COPYRIGHT AND LICENSE
 226
 227 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 228 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 229 redistribute it and/or modify it under the same terms as the
 230 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 231
 232 =cut
 233
 234 1;