X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FStatistics.pm;h=f5216583285ef8e0b3c4cfb07bffa31a145f24b8;hb=02562a2092543488bba4ccd98c39abca72560555;hp=90f66190b8ba69961c31639abaf59ad583e9315d;hpb=d20754315045a6dfdfd8928c1f63c0a49e1a0d0d;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm index 90f6619..f521658 100644 --- a/lib/DBIx/Class/Storage/Statistics.pm +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -1,8 +1,13 @@ 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/); +use DBIx::Class::_Util qw(sigwarn_silencer qsub); +use IO::Handle (); +use Moo; +extends 'DBIx::Class'; +use namespace::clean; =head1 NAME @@ -13,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. @@ -22,25 +27,79 @@ 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({}, 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', +); + +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; } -=head2 debugfh +has [qw(_defaulted_to_stderr silence callback)] => ( + is => 'rw', +); -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. +=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->print($msg); +} + +=head2 silence + +Turn off all output if set to true. =head2 txn_begin @@ -48,9 +107,11 @@ 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 @@ -59,9 +120,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 @@ -70,9 +133,50 @@ Called when a transaction is committed. =cut sub txn_commit { - my $self = shift(); + my $self = shift; + + return if $self->callback; - $self->debugfh->print("COMMIT\n"); + $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 @@ -82,16 +186,17 @@ executed and subsequent arguments are the parameters used for the query. =cut sub query_start { - my $self = shift(); - my $string = shift(); + my ($self, $string, @bind) = @_; - if(defined($self->callback())) { - $string =~ m/^(\w+)/; - $self->callback()->($1, $string); - return; - } + my $message = "$string: ".join(', ', @bind)."\n"; - $self->debugfh->print("$string: " . join(', ', @_) . "\n"); + if(defined($self->callback)) { + $string =~ m/^(\w+)/; + $self->callback->($1, $message); + return; + } + + $self->print($message); } =head2 query_end @@ -99,19 +204,22 @@ sub query_start { 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 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;