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