lib/DBIx/Class/Storage/Statistics.pm

   1 package DBIx::Class::Storage::Statistics;
   2 use strict;
   3 use warnings;
   4
   5 use base qw/Class::Accessor::Grouped/;
   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 it's 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   $self->print("BEGIN WORK\n");
  93 }
  94
  95 =head2 txn_rollback
  96
  97 Called when a transaction is rolled back.
  98
  99 =cut
 100 sub txn_rollback {
 101   my $self = shift;
 102
 103   $self->print("ROLLBACK\n");
 104 }
 105
 106 =head2 txn_commit
 107
 108 Called when a transaction is committed.
 109
 110 =cut
 111 sub txn_commit {
 112   my $self = shift;
 113
 114   $self->print("COMMIT\n");
 115 }
 116
 117 =head2 svp_begin
 118
 119 Called when a savepoint is created.
 120
 121 =cut
 122 sub svp_begin {
 123   my ($self, $name) = @_;
 124
 125   $self->print("SAVEPOINT $name\n");
 126 }
 127
 128 =head2 svp_release
 129
 130 Called when a savepoint is released.
 131
 132 =cut
 133 sub svp_release {
 134   my ($self, $name) = @_;
 135
 136  $self->print("RELEASE SAVEPOINT $name\n");
 137 }
 138
 139 =head2 svp_rollback
 140
 141 Called when rolling back to a savepoint.
 142
 143 =cut
 144 sub svp_rollback {
 145   my ($self, $name) = @_;
 146
 147  $self->print("ROLLBACK TO SAVEPOINT $name\n");
 148 }
 149
 150 =head2 query_start
 151
 152 Called before a query is executed.  The first argument is the SQL string being
 153 executed and subsequent arguments are the parameters used for the query.
 154
 155 =cut
 156 sub query_start {
 157   my ($self, $string, @bind) = @_;
 158
 159   my $message = "$string: ".join(', ', @bind)."\n";
 160
 161   if(defined($self->callback)) {
 162     $string =~ m/^(\w+)/;
 163     $self->callback->($1, $message);
 164     return;
 165   }
 166
 167   $self->print($message);
 168 }
 169
 170 =head2 query_end
 171
 172 Called when a query finishes executing.  Has the same arguments as query_start.
 173
 174 =cut
 175 sub query_end {
 176   my ($self, $string) = @_;
 177 }
 178
 179 1;
 180
 181 =head1 AUTHORS
 182
 183 Cory G. Watson <gphat@cpan.org>
 184
 185 =head1 LICENSE
 186
 187 You may distribute this code under the same license as Perl itself.
 188
 189 =cut