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 has debugfh => (
  49   is => 'rw',
  50   lazy => 1,
  51   trigger => qsub '$_[0]->_defaulted_to_stderr(undef); $_[0]->_clear_debugfh unless $_[1];',
  52   clearer => '_clear_debugfh',
  53   builder => '_build_debugfh',
  54 );
  55
  56 sub _build_debugfh {
  57   my $fh;
  58
  59   my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE};
  60
  61   if (defined($debug_env) and ($debug_env =~ /=(.+)$/)) {
  62     open ($fh, '>>', $1)
  63       or die("Cannot open trace file $1: $!\n");
  64   }
  65   else {
  66     open ($fh, '>&STDERR')
  67       or die("Duplication of STDERR for debug output failed (perhaps your STDERR is closed?): $!\n");
  68     $_[0]->_defaulted_to_stderr(1);
  69   }
  70
  71   $fh->autoflush(1);
  72
  73   $fh;
  74 }
  75
  76 has [qw(_defaulted_to_stderr silence callback)] => (
  77   is => 'rw',
  78 );
  79
  80 =head2 print
  81
  82 Prints the specified string to our debugging filehandle.  Provided to save our
  83 methods the worry of how to display the message.
  84
  85 =cut
  86 sub print {
  87   my ($self, $msg) = @_;
  88
  89   return if $self->silence;
  90
  91   my $fh = $self->debugfh;
  92
  93   # not using 'no warnings' here because all of this can change at runtime
  94   local $SIG{__WARN__} = sigwarn_silencer(qr/^Wide character in print/)
  95     if $self->_defaulted_to_stderr;
  96
  97   $fh->print($msg);
  98 }
  99
 100 =head2 silence
 101
 102 Turn off all output if set to true.
 103
 104 =head2 txn_begin
 105
 106 Called when a transaction begins.
 107
 108 =cut
 109 sub txn_begin {
 110   my $self = shift;
 111
 112   return if $self->callback;
 113
 114   $self->print("BEGIN WORK\n");
 115 }
 116
 117 =head2 txn_rollback
 118
 119 Called when a transaction is rolled back.
 120
 121 =cut
 122 sub txn_rollback {
 123   my $self = shift;
 124
 125   return if $self->callback;
 126
 127   $self->print("ROLLBACK\n");
 128 }
 129
 130 =head2 txn_commit
 131
 132 Called when a transaction is committed.
 133
 134 =cut
 135 sub txn_commit {
 136   my $self = shift;
 137
 138   return if $self->callback;
 139
 140   $self->print("COMMIT\n");
 141 }
 142
 143 =head2 svp_begin
 144
 145 Called when a savepoint is created.
 146
 147 =cut
 148 sub svp_begin {
 149   my ($self, $name) = @_;
 150
 151   return if $self->callback;
 152
 153   $self->print("SAVEPOINT $name\n");
 154 }
 155
 156 =head2 svp_release
 157
 158 Called when a savepoint is released.
 159
 160 =cut
 161 sub svp_release {
 162   my ($self, $name) = @_;
 163
 164   return if $self->callback;
 165
 166   $self->print("RELEASE SAVEPOINT $name\n");
 167 }
 168
 169 =head2 svp_rollback
 170
 171 Called when rolling back to a savepoint.
 172
 173 =cut
 174 sub svp_rollback {
 175   my ($self, $name) = @_;
 176
 177   return if $self->callback;
 178
 179   $self->print("ROLLBACK TO SAVEPOINT $name\n");
 180 }
 181
 182 =head2 query_start
 183
 184 Called before a query is executed.  The first argument is the SQL string being
 185 executed and subsequent arguments are the parameters used for the query.
 186
 187 =cut
 188 sub query_start {
 189   my ($self, $string, @bind) = @_;
 190
 191   my $message = "$string: ".join(', ', @bind)."\n";
 192
 193   if(defined($self->callback)) {
 194     $string =~ m/^(\w+)/;
 195     $self->callback->($1, $message);
 196     return;
 197   }
 198
 199   $self->print($message);
 200 }
 201
 202 =head2 query_end
 203
 204 Called when a query finishes executing.  Has the same arguments as query_start.
 205
 206 =cut
 207
 208 sub query_end {
 209   my ($self, $string) = @_;
 210 }
 211
 212 =head1 FURTHER QUESTIONS?
 213
 214 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 215
 216 =head1 COPYRIGHT AND LICENSE
 217
 218 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 219 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 220 redistribute it and/or modify it under the same terms as the
 221 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 222
 223 =cut
 224
 225 1;