X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FStatistics.pm;h=4894cf7c2021aa4b155b07dca149f1792811b3ae;hb=4d93345c2f06a03076dcb43cb256de5c973c203b;hp=c2a220963e8f9debc49ec1d7bbaa0ca13dbff695;hpb=a0024650c5dfd609c73a3ec954ba13c67870af3f;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm index c2a2209..4894cf7 100644 --- a/lib/DBIx/Class/Storage/Statistics.pm +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -1,11 +1,22 @@ package DBIx::Class::Storage::Statistics; + use strict; use warnings; -use base qw/Class::Accessor::Grouped/; -use IO::File; +# DO NOT edit away without talking to riba first, he will just put it back +# BEGIN pre-Moo2 import block +BEGIN { + my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all}; + local $ENV{PERL_STRICTURES_EXTRA} = 0; + require Moo; Moo->import; + ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} ); +} +# END pre-Moo2 import block -__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/); +extends 'DBIx::Class'; +use DBIx::Class::_Util qw(sigwarn_silencer qsub); +use IO::Handle (); +use namespace::clean; =head1 NAME @@ -16,7 +27,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. @@ -25,56 +36,86 @@ 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<< printflush|IO::Handle/$io->printflush_(_ARGS_) >> 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 for you if one is not +already set. + =cut -sub new { - my $self = {}; - bless $self, (ref($_[0]) || $_[0]); - return $self; +# FIXME - there ought to be a way to fold this into _debugfh itself +# having the undef re-trigger the builder (or better yet a default +# which can be folded in as a qsub) +sub debugfh { + my $self = shift; + + return $self->_debugfh(@_) if @_; + $self->_debugfh || $self->_build_debugfh; } -=head2 debugfh +has _debugfh => ( + is => 'rw', + lazy => 1, + trigger => qsub '$_[0]->_defaulted_to_stderr(undef)', + builder => '_build_debugfh', +); -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. +sub _build_debugfh { + my $fh; + + 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; +} + +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->printflush($msg); } +=head2 silence + +Turn off all output if set to true. + =head2 txn_begin Called when a transaction begins. @@ -83,6 +124,8 @@ Called when a transaction begins. sub txn_begin { my $self = shift; + return if $self->callback; + $self->print("BEGIN WORK\n"); } @@ -94,6 +137,8 @@ Called when a transaction is rolled back. sub txn_rollback { my $self = shift; + return if $self->callback; + $self->print("ROLLBACK\n"); } @@ -105,9 +150,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 @@ -139,12 +225,12 @@ sub query_end { 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Cory G. Watson +See L and L in DBIx::Class =head1 LICENSE -You may distribute this code under the same license as Perl itself. +You may distribute this code under the same terms as Perl itself. =cut