X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FStatistics.pm;h=42137bfdcb374c5730c5978aa3546ca59a4336b0;hb=7f95ea9928d36f9bd41f3c3f45fcb84a62f35577;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..42137bf 100644 --- a/lib/DBIx/Class/Storage/Statistics.pm +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -1,11 +1,13 @@ package DBIx::Class::Storage::Statistics; + use strict; use warnings; -use base qw/Class::Accessor::Grouped/; -use IO::File; - -__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh silence/); +use DBIx::Class::_Util qw(sigwarn_silencer qsub); +use IO::Handle (); +use Moo; +extends 'DBIx::Class'; +use namespace::clean; =head1 NAME @@ -16,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. @@ -25,32 +27,69 @@ 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; +# 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->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 { @@ -58,25 +97,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; + + # 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; - $self->debugfh->print($msg); + $fh->print($msg); } +=head2 silence + +Turn off all output if set to true. + =head2 txn_begin Called when a transaction begins. @@ -85,6 +118,8 @@ Called when a transaction begins. sub txn_begin { my $self = shift; + return if $self->callback; + $self->print("BEGIN WORK\n"); } @@ -96,6 +131,8 @@ Called when a transaction is rolled back. sub txn_rollback { my $self = shift; + return if $self->callback; + $self->print("ROLLBACK\n"); } @@ -107,6 +144,8 @@ Called when a transaction is committed. sub txn_commit { my $self = shift; + return if $self->callback; + $self->print("COMMIT\n"); } @@ -118,6 +157,8 @@ Called when a savepoint is created. sub svp_begin { my ($self, $name) = @_; + return if $self->callback; + $self->print("SAVEPOINT $name\n"); } @@ -129,7 +170,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 +183,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 @@ -168,18 +213,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;