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