lib/DBIx/Class/Storage/Statistics.pm

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