lib/DBIx/Class/Storage/Statistics.pm

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