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