X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FStatistics.pm;h=d4937d1932391deb3eeed718c4cd3d8838d8798a;hb=c6fa3170af14483e9d749931642fdd3000baa28c;hp=d79549054bfb00a45550b7ed45250929098af879;hpb=472a4e8f5437429e5dfae20abd709462a6309979;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm index d795490..d4937d1 100644 --- a/lib/DBIx/Class/Storage/Statistics.pm +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -1,8 +1,11 @@ package DBIx::Class::Storage::Statistics; use strict; +use warnings; -use base qw/DBIx::Class::AccessorGroup Class::Data::Accessor/; -__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/); +use base qw/DBIx::Class/; +use IO::File; + +__PACKAGE__->mk_group_accessors(simple => qw/callback _debugfh silence/); =head1 NAME @@ -13,7 +16,7 @@ DBIx::Class::Storage::Statistics - SQL Statistics =head1 DESCRIPTION This class is called by DBIx::Class::Storage::DBI as a means of collecting -statistics on it's actions. Using this class alone merely prints the SQL +statistics on its actions. Using this class alone merely prints the SQL executed, the fact that it completes and begin/end notification for transactions. @@ -30,9 +33,10 @@ Returns a new L object. =cut sub new { - my $self = bless({}, ref($_[0]) || $_[0]); + my $self = {}; + bless $self, (ref($_[0]) || $_[0]); - return $self; + return $self; } =head2 debugfh @@ -42,15 +46,63 @@ be an IO::Handle compatible object (only the C method is used). Initially should be set to STDERR - although see information on the L environment variable. +As getter it will lazily open a filehandle for you if one is not already set. + +=cut + +sub debugfh { + my $self = shift; + + if (@_) { + $self->_debugfh($_[0]); + } elsif (!defined($self->_debugfh())) { + my $fh; + my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} + || $ENV{DBIC_TRACE}; + if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) { + $fh = IO::File->new($1, 'w') + or die("Cannot open trace file $1"); + } else { + $fh = IO::File->new('>&STDERR') + or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)'); + } + + $fh->autoflush(); + $self->_debugfh($fh); + } + + $self->_debugfh; +} + +=head2 print + +Prints the specified string to our debugging filehandle. Provided to save our +methods the worry of how to display the message. + +=cut +sub print { + my ($self, $msg) = @_; + + return if $self->silence; + + $self->debugfh->print($msg); +} + +=head2 silence + +Turn off all output if set to true. + =head2 txn_begin Called when a transaction begins. =cut sub txn_begin { - my $self = shift(); + my $self = shift; + + return if $self->callback; - $self->debugfh->print("BEGIN WORK\n"); + $self->print("BEGIN WORK\n"); } =head2 txn_rollback @@ -59,9 +111,11 @@ Called when a transaction is rolled back. =cut sub txn_rollback { - my $self = shift(); + my $self = shift; + + return if $self->callback; - $self->debugfh->print("ROLLBACK\n"); + $self->print("ROLLBACK\n"); } =head2 txn_commit @@ -70,9 +124,50 @@ Called when a transaction is committed. =cut sub txn_commit { - my $self = shift(); + my $self = shift; + + return if $self->callback; + + $self->print("COMMIT\n"); +} + +=head2 svp_begin + +Called when a savepoint is created. + +=cut +sub svp_begin { + my ($self, $name) = @_; + + return if $self->callback; + + $self->print("SAVEPOINT $name\n"); +} + +=head2 svp_release + +Called when a savepoint is released. + +=cut +sub svp_release { + my ($self, $name) = @_; + + return if $self->callback; - $self->debugfh->print("COMMIT\n"); + $self->print("RELEASE SAVEPOINT $name\n"); +} + +=head2 svp_rollback + +Called when rolling back to a savepoint. + +=cut +sub svp_rollback { + my ($self, $name) = @_; + + return if $self->callback; + + $self->print("ROLLBACK TO SAVEPOINT $name\n"); } =head2 query_start @@ -82,16 +177,17 @@ executed and subsequent arguments are the parameters used for the query. =cut sub query_start { - my $self = shift(); - my $string = shift(); + my ($self, $string, @bind) = @_; - if(defined($self->callback())) { - $string =~ m/^(\w+)/; - $self->callback()->($1, $string, @_); - return; - } + my $message = "$string: ".join(', ', @bind)."\n"; + + if(defined($self->callback)) { + $string =~ m/^(\w+)/; + $self->callback->($1, $message); + return; + } - $self->debugfh->print("$string: " . join(', ', @_) . "\n"); + $self->print($message); } =head2 query_end @@ -100,8 +196,7 @@ Called when a query finishes executing. Has the same arguments as query_start. =cut sub query_end { - my $self = shift(); - my $string = shift(); + my ($self, $string) = @_; } 1;