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 query_start
 112
 113 Called before a query is executed.  The first argument is the SQL string being
 114 executed and subsequent arguments are the parameters used for the query.
 115
 116 =cut
 117 sub query_start {
 118   my ($self, $string, @bind) = @_;
 119
 120   my $message = "$string: ".join(', ', @bind)."\n";
 121
 122   if(defined($self->callback)) {
 123     $string =~ m/^(\w+)/;
 124     $self->callback->($1, $message);
 125     return;
 126   }
 127
 128   $self->print($message);
 129 }
 130
 131 =head2 query_end
 132
 133 Called when a query finishes executing.  Has the same arguments as query_start.
 134
 135 =cut
 136 sub query_end {
 137   my ($self, $string) = @_;
 138 }
 139
 140 1;
 141
 142 =head1 AUTHORS
 143
 144 Cory G. Watson <gphat@cpan.org>
 145
 146 =head1 LICENSE
 147
 148 You may distribute this code under the same license as Perl itself.
 149
 150 =cut