lib/DBIx/Class/Storage/Statistics.pm

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