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=c0a985364c7d86dc6e45328005f207a88bb4e6fd;hpb=9901aad73ff9dc45b426534fe406c102fb9fb77c;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm index c0a9853..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 silence/); +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,32 +36,66 @@ 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 { @@ -58,25 +103,19 @@ sub print { return if $self->silence; - 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); - } + 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. @@ -85,6 +124,8 @@ Called when a transaction begins. sub txn_begin { my $self = shift; + return if $self->callback; + $self->print("BEGIN WORK\n"); } @@ -96,6 +137,8 @@ Called when a transaction is rolled back. sub txn_rollback { my $self = shift; + return if $self->callback; + $self->print("ROLLBACK\n"); } @@ -107,6 +150,8 @@ Called when a transaction is committed. sub txn_commit { my $self = shift; + return if $self->callback; + $self->print("COMMIT\n"); } @@ -118,6 +163,8 @@ Called when a savepoint is created. sub svp_begin { my ($self, $name) = @_; + return if $self->callback; + $self->print("SAVEPOINT $name\n"); } @@ -129,7 +176,9 @@ Called when a savepoint is released. sub svp_release { my ($self, $name) = @_; - $self->print("RELEASE SAVEPOINT $name\n"); + return if $self->callback; + + $self->print("RELEASE SAVEPOINT $name\n"); } =head2 svp_rollback @@ -140,7 +189,9 @@ Called when rolling back to a savepoint. sub svp_rollback { my ($self, $name) = @_; - $self->print("ROLLBACK TO SAVEPOINT $name\n"); + return if $self->callback; + + $self->print("ROLLBACK TO SAVEPOINT $name\n"); } =head2 query_start @@ -174,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