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