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
   7 __PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/);
   8
   9 =head1 NAME
  10
  11 DBIx::Class::Storage::Statistics - SQL Statistics
  12
  13 =head1 SYNOPSIS
  14
  15 =head1 DESCRIPTION
  16
  17 This class is called by DBIx::Class::Storage::DBI as a means of collecting
  18 statistics on it's actions.  Using this class alone merely prints the SQL
  19 executed, the fact that it completes and begin/end notification for
  20 transactions.
  21
  22 To really use this class you should subclass it and create your own method
  23 for collecting the statistics as discussed in L<DBIx::Class::Manual::Cookbook>.
  24
  25 =head1 METHODS
  26
  27 =cut
  28
  29 =head2 new
  30
  31 Returns a new L<DBIx::Class::Storage::Statistics> object.
  32
  33 =cut
  34 sub new {
  35   my $self = {};
  36   bless $self, (ref($_[0]) || $_[0]);
  37
  38   return $self;
  39 }
  40
  41 =head2 debugfh
  42
  43 Sets or retrieves the filehandle used for trace/debug output.  This should
  44 be an IO::Handle compatible object (only the C<print> method is used). Initially
  45 should be set to STDERR - although see information on the
  46 L<DBIC_TRACE> environment variable.
  47
  48 =head2 print
  49
  50 Prints the specified string to our debugging filehandle, which we will attempt
  51 to open if we haven't yet.  Provided to save our methods the worry of how
  52 to display the message.
  53
  54 =cut
  55 sub print {
  56   my ($self, $msg) = @_;
  57
  58   if(!defined($self->debugfh())) {
  59     my $fh;
  60     my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
  61                   || $ENV{DBIC_TRACE};
  62     if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
  63       $fh = IO::File->new($1, 'w')
  64         or die("Cannot open trace file $1");
  65     } else {
  66       $fh = IO::File->new('>&STDERR')
  67         or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
  68     }
  69
  70     $fh->autoflush();
  71     $self->debugfh($fh);
  72   }
  73
  74   $self->debugfh->print($msg);
  75 }
  76
  77 =head2 txn_begin
  78
  79 Called when a transaction begins.
  80
  81 =cut
  82 sub txn_begin {
  83   my $self = shift;
  84
  85   $self->print("BEGIN WORK\n");
  86 }
  87
  88 =head2 txn_rollback
  89
  90 Called when a transaction is rolled back.
  91
  92 =cut
  93 sub txn_rollback {
  94   my $self = shift;
  95
  96   $self->print("ROLLBACK\n");
  97 }
  98
  99 =head2 txn_commit
 100
 101 Called when a transaction is committed.
 102
 103 =cut
 104 sub txn_commit {
 105   my $self = shift;
 106
 107   $self->print("COMMIT\n");
 108 }
 109
 110 =head2 query_start
 111
 112 Called before a query is executed.  The first argument is the SQL string being
 113 executed and subsequent arguments are the parameters used for the query.
 114
 115 =cut
 116 sub query_start {
 117   my ($self, $string, @bind) = @_;
 118
 119   my $message = "$string: ".join(', ', @bind)."\n";
 120
 121   if(defined($self->callback)) {
 122     $string =~ m/^(\w+)/;
 123     $self->callback->($1, $message);
 124     return;
 125   }
 126
 127   $self->print($message);
 128 }
 129
 130 =head2 query_end
 131
 132 Called when a query finishes executing.  Has the same arguments as query_start.
 133
 134 =cut
 135 sub query_end {
 136   my ($self, $string) = @_;
 137 }
 138
 139 1;
 140
 141 =head1 AUTHORS
 142
 143 Cory G. Watson <gphat@cpan.org>
 144
 145 =head1 LICENSE
 146
 147 You may distribute this code under the same license as Perl itself.
 148
 149 =cut