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