X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FStatistics.pm;h=f5216583285ef8e0b3c4cfb07bffa31a145f24b8;hb=0ff3368690783358903b3689a1a96ef21271f825;hp=e94203ebb46ad705c89bd64e5cea969a7af66788;hpb=70f3927877ba6b7aac2565bc1933daaf82361308;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm index e94203e..f521658 100644 --- a/lib/DBIx/Class/Storage/Statistics.pm +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -1,10 +1,13 @@ package DBIx::Class::Storage::Statistics; + use strict; use warnings; -use base qw/Class::Accessor::Grouped/; - -__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/); +use DBIx::Class::_Util qw(sigwarn_silencer qsub); +use IO::Handle (); +use Moo; +extends 'DBIx::Class'; +use namespace::clean; =head1 NAME @@ -15,7 +18,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. @@ -24,56 +27,80 @@ for collecting the statistics as discussed in L. =head1 METHODS -=cut - =head2 new Returns a new L object. +=head2 debugfh + +Sets or retrieves the filehandle used for trace/debug output. This should +be an L compatible object (only the +L<< print|IO::Handle/METHODS >> method is used). By +default it is initially set to STDERR - although see discussion of the +L environment variable. + +Invoked as a getter it will lazily open a filehandle and set it to +L<< autoflush|perlvar/HANDLE->autoflush( EXPR ) >> (if one is not +already set). + =cut -sub new { - my $self = {}; - bless $self, (ref($_[0]) || $_[0]); - return $self; -} +has debugfh => ( + is => 'rw', + lazy => 1, + trigger => qsub '$_[0]->_defaulted_to_stderr(undef); $_[0]->_clear_debugfh unless $_[1];', + clearer => '_clear_debugfh', + builder => '_build_debugfh', +); -=head2 debugfh +sub _build_debugfh { + my $fh; -Sets or retrieves the filehandle used for trace/debug output. This should -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. + my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE}; + + if (defined($debug_env) and ($debug_env =~ /=(.+)$/)) { + open ($fh, '>>', $1) + or die("Cannot open trace file $1: $!\n"); + } + else { + open ($fh, '>&STDERR') + or die("Duplication of STDERR for debug output failed (perhaps your STDERR is closed?): $!\n"); + $_[0]->_defaulted_to_stderr(1); + } + + $fh->autoflush(1); + + $fh; +} + +has [qw(_defaulted_to_stderr silence callback)] => ( + is => 'rw', +); =head2 print -Prints the specified string to our debugging filehandle, which we will attempt -to open if we haven't yet. Provided to save our methods the worry of how -to display the message. +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) = @_; - if(!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); - } + return if $self->silence; + + my $fh = $self->debugfh; - $self->debugfh->print($msg); + # not using 'no warnings' here because all of this can change at runtime + local $SIG{__WARN__} = sigwarn_silencer(qr/^Wide character in print/) + if $self->_defaulted_to_stderr; + + $fh->print($msg); } +=head2 silence + +Turn off all output if set to true. + =head2 txn_begin Called when a transaction begins. @@ -82,6 +109,8 @@ Called when a transaction begins. sub txn_begin { my $self = shift; + return if $self->callback; + $self->print("BEGIN WORK\n"); } @@ -93,6 +122,8 @@ Called when a transaction is rolled back. sub txn_rollback { my $self = shift; + return if $self->callback; + $self->print("ROLLBACK\n"); } @@ -104,9 +135,50 @@ Called when a transaction is committed. sub txn_commit { 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->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 Called before a query is executed. The first argument is the SQL string being @@ -132,18 +204,22 @@ sub query_start { Called when a query finishes executing. Has the same arguments as query_start. =cut + sub query_end { my ($self, $string) = @_; } -1; - -=head1 AUTHORS +=head1 FURTHER QUESTIONS? -Cory G. Watson +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same license as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1;