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 IO::Handle ();
  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 L<IO::Handle> compatible object (only the
  47 L<< printflush|IO::Handle/$io->printflush_(_ARGS_) >> method is used). By
  48 default it is initially set to STDERR - although see discussion of the
  49 L<DBIC_TRACE|DBIx::Class::Storage/DBIC_TRACE> environment variable.
  50
  51 Invoked as a getter it will lazily open a filehandle for you 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;
  89 }
  90
  91 has [qw(_defaulted_to_stderr silence callback)] => (
  92   is => 'rw',
  93 );
  94
  95 =head2 print
  96
  97 Prints the specified string to our debugging filehandle.  Provided to save our
  98 methods the worry of how to display the message.
  99
 100 =cut
 101 sub print {
 102   my ($self, $msg) = @_;
 103
 104   return if $self->silence;
 105
 106   my $fh = $self->debugfh;
 107
 108   # not using 'no warnings' here because all of this can change at runtime
 109   local $SIG{__WARN__} = sigwarn_silencer(qr/^Wide character in print/)
 110     if $self->_defaulted_to_stderr;
 111
 112   $fh->printflush($msg);
 113 }
 114
 115 =head2 silence
 116
 117 Turn off all output if set to true.
 118
 119 =head2 txn_begin
 120
 121 Called when a transaction begins.
 122
 123 =cut
 124 sub txn_begin {
 125   my $self = shift;
 126
 127   return if $self->callback;
 128
 129   $self->print("BEGIN WORK\n");
 130 }
 131
 132 =head2 txn_rollback
 133
 134 Called when a transaction is rolled back.
 135
 136 =cut
 137 sub txn_rollback {
 138   my $self = shift;
 139
 140   return if $self->callback;
 141
 142   $self->print("ROLLBACK\n");
 143 }
 144
 145 =head2 txn_commit
 146
 147 Called when a transaction is committed.
 148
 149 =cut
 150 sub txn_commit {
 151   my $self = shift;
 152
 153   return if $self->callback;
 154
 155   $self->print("COMMIT\n");
 156 }
 157
 158 =head2 svp_begin
 159
 160 Called when a savepoint is created.
 161
 162 =cut
 163 sub svp_begin {
 164   my ($self, $name) = @_;
 165
 166   return if $self->callback;
 167
 168   $self->print("SAVEPOINT $name\n");
 169 }
 170
 171 =head2 svp_release
 172
 173 Called when a savepoint is released.
 174
 175 =cut
 176 sub svp_release {
 177   my ($self, $name) = @_;
 178
 179   return if $self->callback;
 180
 181   $self->print("RELEASE SAVEPOINT $name\n");
 182 }
 183
 184 =head2 svp_rollback
 185
 186 Called when rolling back to a savepoint.
 187
 188 =cut
 189 sub svp_rollback {
 190   my ($self, $name) = @_;
 191
 192   return if $self->callback;
 193
 194   $self->print("ROLLBACK TO SAVEPOINT $name\n");
 195 }
 196
 197 =head2 query_start
 198
 199 Called before a query is executed.  The first argument is the SQL string being
 200 executed and subsequent arguments are the parameters used for the query.
 201
 202 =cut
 203 sub query_start {
 204   my ($self, $string, @bind) = @_;
 205
 206   my $message = "$string: ".join(', ', @bind)."\n";
 207
 208   if(defined($self->callback)) {
 209     $string =~ m/^(\w+)/;
 210     $self->callback->($1, $message);
 211     return;
 212   }
 213
 214   $self->print($message);
 215 }
 216
 217 =head2 query_end
 218
 219 Called when a query finishes executing.  Has the same arguments as query_start.
 220
 221 =cut
 222 sub query_end {
 223   my ($self, $string) = @_;
 224 }
 225
 226 1;
 227
 228 =head1 AUTHOR AND CONTRIBUTORS
 229
 230 See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
 231
 232 =head1 LICENSE
 233
 234 You may distribute this code under the same terms as Perl itself.
 235
 236 =cut