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 IO::File;
   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       $fh = IO::File->new($1, 'w')
  64         or die("Cannot open trace file $1");
  65     } else {
  66       $fh = IO::File->new('>&STDERR')
  67         or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
  68     }
  69
  70     $fh->autoflush();
  71     $self->_debugfh($fh);
  72   }
  73
  74   $self->_debugfh;
  75 }
  76
  77 =head2 print
  78
  79 Prints the specified string to our debugging filehandle.  Provided to save our
  80 methods the worry of how to display the message.
  81
  82 =cut
  83 sub print {
  84   my ($self, $msg) = @_;
  85
  86   return if $self->silence;
  87
  88   $self->debugfh->print($msg);
  89 }
  90
  91 =head2 silence
  92
  93 Turn off all output if set to true.
  94
  95 =head2 txn_begin
  96
  97 Called when a transaction begins.
  98
  99 =cut
 100 sub txn_begin {
 101   my $self = shift;
 102
 103   return if $self->callback;
 104
 105   $self->print("BEGIN WORK\n");
 106 }
 107
 108 =head2 txn_rollback
 109
 110 Called when a transaction is rolled back.
 111
 112 =cut
 113 sub txn_rollback {
 114   my $self = shift;
 115
 116   return if $self->callback;
 117
 118   $self->print("ROLLBACK\n");
 119 }
 120
 121 =head2 txn_commit
 122
 123 Called when a transaction is committed.
 124
 125 =cut
 126 sub txn_commit {
 127   my $self = shift;
 128
 129   return if $self->callback;
 130
 131   $self->print("COMMIT\n");
 132 }
 133
 134 =head2 svp_begin
 135
 136 Called when a savepoint is created.
 137
 138 =cut
 139 sub svp_begin {
 140   my ($self, $name) = @_;
 141
 142   return if $self->callback;
 143
 144   $self->print("SAVEPOINT $name\n");
 145 }
 146
 147 =head2 svp_release
 148
 149 Called when a savepoint is released.
 150
 151 =cut
 152 sub svp_release {
 153   my ($self, $name) = @_;
 154
 155   return if $self->callback;
 156
 157   $self->print("RELEASE SAVEPOINT $name\n");
 158 }
 159
 160 =head2 svp_rollback
 161
 162 Called when rolling back to a savepoint.
 163
 164 =cut
 165 sub svp_rollback {
 166   my ($self, $name) = @_;
 167
 168   return if $self->callback;
 169
 170   $self->print("ROLLBACK TO SAVEPOINT $name\n");
 171 }
 172
 173 =head2 query_start
 174
 175 Called before a query is executed.  The first argument is the SQL string being
 176 executed and subsequent arguments are the parameters used for the query.
 177
 178 =cut
 179 sub query_start {
 180   my ($self, $string, @bind) = @_;
 181
 182   my $message = "$string: ".join(', ', @bind)."\n";
 183
 184   if(defined($self->callback)) {
 185     $string =~ m/^(\w+)/;
 186     $self->callback->($1, $message);
 187     return;
 188   }
 189
 190   $self->print($message);
 191 }
 192
 193 =head2 query_end
 194
 195 Called when a query finishes executing.  Has the same arguments as query_start.
 196
 197 =cut
 198 sub query_end {
 199   my ($self, $string) = @_;
 200 }
 201
 202 1;
 203
 204 =head1 AUTHORS
 205
 206 Cory G. Watson <gphat@cpan.org>
 207
 208 =head1 LICENSE
 209
 210 You may distribute this code under the same license as Perl itself.
 211
 212 =cut