X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FStatistics.pm;h=e241ad4297d81f23e131d3efa83fdb148f3de65d;hb=7f9a3f70074c5d4eb4e8260648f055b7556a7a4f;hp=cd16fb541494a3297e359e6b0c1cab3f3a02eff8;hpb=aaba95249e9b4a986ff3f5820e6c95e2ecae68f9;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm index cd16fb5..e241ad4 100644 --- a/lib/DBIx/Class/Storage/Statistics.pm +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -1,9 +1,21 @@ 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/); +# 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 + +extends 'DBIx::Class'; +use DBIx::Class::_Util qw(sigwarn_silencer qsub); +use namespace::clean; =head1 NAME @@ -14,7 +26,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. @@ -23,20 +35,10 @@ for collecting the statistics as discussed in L. =head1 METHODS -=cut - =head2 new Returns a new L object. -=cut -sub new { - my $self = {}; - bless $self, (ref($_[0]) || $_[0]); - - return $self; -} - =head2 debugfh Sets or retrieves the filehandle used for trace/debug output. This should @@ -44,15 +46,84 @@ 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 + +# 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; +} + +has _debugfh => ( + is => 'rw', + lazy => 1, + trigger => qsub '$_[0]->_defaulted_to_stderr(undef)', + builder => '_build_debugfh', +); + +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. Provided to save our +methods the worry of how to display the message. + +=cut +sub print { + my ($self, $msg) = @_; + + return if $self->silence; + + my $fh = $self->debugfh; + + # 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. =cut sub txn_begin { - my $self = shift(); + my $self = shift; - $self->debugfh->print("BEGIN WORK\n"); + return if $self->callback; + + $self->print("BEGIN WORK\n"); } =head2 txn_rollback @@ -61,9 +132,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 @@ -72,9 +145,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->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->debugfh->print("COMMIT\n"); + $self->print("ROLLBACK TO SAVEPOINT $name\n"); } =head2 query_start @@ -84,17 +198,17 @@ executed and subsequent arguments are the parameters used for the query. =cut sub query_start { - my ($self, $string, @bind) = @_; + my ($self, $string, @bind) = @_; - my $message = "$string: ".join(', ', @bind)."\n"; + my $message = "$string: ".join(', ', @bind)."\n"; - if(defined($self->callback())) { - $string =~ m/^(\w+)/; - $self->callback()->($1, $message); - return; - } + if(defined($self->callback)) { + $string =~ m/^(\w+)/; + $self->callback->($1, $message); + return; + } - $self->debugfh->print($message); + $self->print($message); } =head2 query_end @@ -103,18 +217,17 @@ 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; -=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