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