From: Cory G Watson Date: Mon, 15 May 2006 17:46:01 +0000 (+0000) Subject: Add profiling support X-Git-Tag: v0.07002~75^2~190 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4c24816137de09c629fcd3da41b7626d50cc13f6;p=dbsrgits%2FDBIx-Class.git Add profiling support --- diff --git a/Changes b/Changes index ffc03a2..3a51cb7 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,6 @@ Revision history for DBIx::Class + - refactor debugging to allow for profiling using Storage::Statistics - removed Data::UUID from deps, made other optionals required - modified SQLT parser to skip dupe table names - added remove_column(s) to ResultSource/ResultSourceProxy diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index f141676..75b87d6 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -228,6 +228,8 @@ Todd Lipcon wdh: Will Hawes +gphat: Cory G Watson + =head1 LICENSE You may distribute this code under the same terms as Perl itself. diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index e82426e..081a4d0 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -786,4 +786,64 @@ It is possible to get a Schema object from a row object like so, This can be useful when you don't want to pass around a Schema object to every method. +=head2 Profiling + +When you enable L's debugging it prints the SQL +executed as well as notifications of query completion and transaction +begin/commit. If you'd like to profile the SQL you can subclass the +L class and write your own profiling +mechanism: + + package My::Profiler; + use strict; + + use base 'DBIx::Class::Storage::Statistics'; + + use Time::HiRes qw(time); + + my $start; + + sub query_start { + my $self = shift(); + my $sql = shift(); + my $params = @_; + + print "Executing $sql: ".join(', ', @params)."\n"; + $start = time(); + } + + sub query_end { + my $self = shift(); + my $sql = shift(); + my @params = @_; + + printf("Execution took %0.4f seconds.\n", time() - $start); + $start = undef; + } + + 1; + +You can then install that class as the debugging object: + + __PACKAGE__->storage()->debugobj(new My::Profiler()); + __PACKAGE__->storage()->debug(1); + +A more complicated example might involve storing each execution of SQL in an +array: + + sub query_end { + my $self = shift(); + my $sql = shift(); + my @params = @_; + + my $elapsed = time() - $start; + push(@{ $calls{$sql} }, { + params => \@params, + elapsed => $elapsed + }); + } + +You could then create average, high and low execution times for an SQL +statement and dig down to see if certain parameters cause aberrant behavior. + =cut diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 1d0b5f0..bf556cb 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -8,9 +8,9 @@ use warnings; use DBI; use SQL::Abstract::Limit; use DBIx::Class::Storage::DBI::Cursor; +use DBIx::Class::Storage::Statistics; use IO::File; use Carp::Clan qw/DBIx::Class/; - BEGIN { package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :( @@ -225,17 +225,6 @@ sub name_sep { return $self->{name_sep}; } - - - -package DBIx::Class::Storage::DBI::DebugCallback; - -sub print { - my ($self, $string) = @_; - $string =~ m/^(\w+)/; - ${$self}->($1, $string); -} - } # End of BEGIN block use base qw/DBIx::Class/; @@ -243,20 +232,25 @@ use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/AccessorGroup/); __PACKAGE__->mk_group_accessors('simple' => - qw/_connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugfh + qw/_connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugobj cursor on_connect_do transaction_depth/); sub new { my $new = bless({}, ref $_[0] || $_[0]); $new->cursor("DBIx::Class::Storage::DBI::Cursor"); $new->transaction_depth(0); + + $new->debugobj(new DBIx::Class::Storage::Statistics()); + + my $fh; if (defined($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}) && ($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} =~ /=(.+)$/)) { - $new->debugfh(IO::File->new($1, 'w')) + $fh = IO::File->new($1, 'w') or $new->throw_exception("Cannot open trace file $1"); } else { - $new->debugfh(IO::File->new('>&STDERR')); + $fh = IO::File->new('>&STDERR'); } + $new->debugobj->debugfh($fh); $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}; return $new; } @@ -305,29 +299,38 @@ Executes the sql statements given as a listref on every db connect. =head2 debug -Causes SQL trace information to be emitted on C filehandle -(or C if C has not specifically been set). +Causes SQL trace information to be emitted on the C object. +(or C if C has not specifically been set). =head2 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 set to be STDERR - although see information on the +Set or retrieve the filehandle used for trace/debug output. This should be +an IO::Handle compatible ojbect (only the C method is used. Initially +set to be STDERR - although see information on the L environment variable. +=head2 debugobj + +Sets or retrieves the object used for metric collection. Defaults to an instance +of L that is campatible with the original +method of using a coderef as a callback. See the aforementioned Statistics +class for more information. + =head2 debugcb Sets a callback to be executed each time a statement is run; takes a sub -reference. Overrides debugfh. Callback is executed as $sub->($op, $info) -where $op is SELECT/INSERT/UPDATE/DELETE and $info is what would normally -be printed. +reference. Callback is executed as $sub->($op, $info) where $op is +SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed. -=cut +See L for a better way. +=cut sub debugcb { - my ($self, $cb) = @_; - my $cb_obj = bless(\$cb, 'DBIx::Class::Storage::DBI::DebugCallback'); - $self->debugfh($cb_obj); + my $self = shift(); + + if($self->debugobj()->can('callback')) { + $self->debugobj()->callback(shift()); + } } sub disconnect { @@ -437,7 +440,9 @@ sub _populate_dbh { } # if on-connect sql statements are given execute them foreach my $sql_statement (@{$self->on_connect_do || []}) { + $self->debugobj->query_start($sql_statement) if $self->debug(); $self->_dbh->do($sql_statement); + $self->debugobj->query_end($sql_statement) if $self->debug(); } $self->_conn_pid($$); @@ -489,7 +494,7 @@ sub txn_begin { if ($self->{transaction_depth}++ == 0) { my $dbh = $self->dbh; if ($dbh->{AutoCommit}) { - $self->debugfh->print("BEGIN WORK\n") + $self->debugobj->txn_begin() if ($self->debug); $dbh->begin_work; } @@ -507,14 +512,14 @@ sub txn_commit { if ($self->{transaction_depth} == 0) { my $dbh = $self->dbh; unless ($dbh->{AutoCommit}) { - $self->debugfh->print("COMMIT\n") + $self->debugobj->txn_commit() if ($self->debug); $dbh->commit; } } else { if (--$self->{transaction_depth} == 0) { - $self->debugfh->print("COMMIT\n") + $self->debugobj->txn_commit() if ($self->debug); $self->dbh->commit; } @@ -536,14 +541,14 @@ sub txn_rollback { if ($self->{transaction_depth} == 0) { my $dbh = $self->dbh; unless ($dbh->{AutoCommit}) { - $self->debugfh->print("ROLLBACK\n") + $self->debugobj->txn_rollback() if ($self->debug); $dbh->rollback; } } else { if (--$self->{transaction_depth} == 0) { - $self->debugfh->print("ROLLBACK\n") + $self->debugobj->txn_rollback() if ($self->debug); $self->dbh->rollback; } @@ -568,7 +573,7 @@ sub _execute { unshift(@bind, @$extra_bind) if $extra_bind; if ($self->debug) { my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind; - $self->debugfh->print("$sql: " . join(', ', @debug_bind) . "\n"); + $self->debugobj->query_start($sql, @debug_bind); } my $sth = eval { $self->sth($sql,$op) }; @@ -579,6 +584,7 @@ sub _execute { @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args my $rv; if ($sth) { + my $time = time(); $rv = eval { $sth->execute(@bind) }; if ($@ || !$rv) { @@ -587,6 +593,10 @@ sub _execute { } else { $self->throw_exception("'$sql' did not generate a statement."); } + if ($self->debug) { + my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind; + $self->debugobj->query_end($sql, @debug_bind); + } return (wantarray ? ($rv, $sth, @bind) : $rv); } @@ -822,8 +832,9 @@ sub deploy { # next if($_ =~ /^DROP/m); next if($_ =~ /^BEGIN TRANSACTION/m); next if($_ =~ /^COMMIT/m); - $self->debugfh->print("$_\n") if $self->debug; + $self->debugobj->query_begin($_) if $self->debug; $self->dbh->do($_) or warn "SQL was:\n $_"; + $self->debugobj->query_end($_) if $self->debug; } } } diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm new file mode 100644 index 0000000..ec9edda --- /dev/null +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -0,0 +1,111 @@ +package DBIx::Class::Storage::Statistics; +use strict; + +use base qw/DBIx::Class::AccessorGroup Class::Data::Accessor/; +__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/); + +=head1 NAME + +DBIx::Class::Storage::Statistics - SQL Statistics + +=head1 SYNOPSIS + +=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 +executed, the fact that it completes and begin/end notification for +transactions. + +To really use this class you should subclass it and create your own method +for collecting the statistics as discussed in L. + +=head1 METHODS + +=cut + +=head2 new + +Returns a new L object. + +=cut +sub new { + my $self = bless({}, ref($_[0]) || $_[0]); + + return $self; +} + +=head2 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. + +=head2 txn_begin + +Called when a transaction begins. + +=cut +sub txn_begin { + my $self = shift(); +} + +=head2 txn_rollback + +Called when a transaction is rolled back. + +=cut +sub txn_rollback { + my $self = shift(); +} + +=head2 txn_commit + +Called when a transaction is committed. + +=cut +sub txn_commit { + my $self = shift(); +} + +=head2 query_start + +Called before a query is executed. The first argument is the SQL string being +executed and subsequent arguments are the parameters used for the query. + +=cut +sub query_start { + my $self = shift(); + my $string = shift(); + + if(defined($self->callback())) { + $string =~ m/^(\w+)/; + $self->callback()->($1, $string); + return; + } + + $self->debugfh->print("$string: " . join(', ', @_) . "\n"); +} + +=head2 query_end + +Called when a query finishes executing. Has the same arguments as query_start. + +=cut +sub query_end { + my $self = shift(); + my $string = shift(); +} + +1; + +=head1 AUTHORS + +Cory G. Watson + +=head1 LICENSE + +You may distribute this code under the same license as Perl itself. + +=cut diff --git a/t/31stats.t b/t/31stats.t new file mode 100644 index 0000000..a478d28 --- /dev/null +++ b/t/31stats.t @@ -0,0 +1,109 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Test::More; + +BEGIN { + eval "use DBD::SQLite"; + plan $@ + ? ( skip_all => 'needs DBD::SQLite for testing' ) + : ( tests => 13 ); +} + +use lib qw(t/lib); + +use_ok('DBICTest'); +use_ok('DBICTest::HelperRels'); + +my $cbworks = 0; + +DBICTest->schema->storage->debugcb(sub { $cbworks = 1; }); +DBICTest->schema->storage->debug(0); +my $rs = DBICTest::CD->search({}); +$rs->count(); +ok(!$cbworks, 'Callback not called with debug disabled'); + +DBICTest->schema->storage->debug(1); + +$rs->count(); +ok($cbworks, 'Debug callback worked.'); + +my $prof = new DBIx::Test::Profiler(); +DBICTest->schema->storage->debugobj($prof); + +# Test non-transaction calls. +$rs->count(); +ok($prof->{'query_start'}, 'query_start called'); +ok($prof->{'query_end'}, 'query_end called'); +ok(!$prof->{'txn_begin'}, 'txn_begin not called'); +ok(!$prof->{'txn_commit'}, 'txn_commit not called'); + +$prof->reset(); + +# Test transaction calls +DBICTest->schema->txn_begin(); +ok($prof->{'txn_begin'}, 'txn_begin called'); + +$rs = DBICTest::CD->search({}); +$rs->count(); +ok($prof->{'query_start'}, 'query_start called'); +ok($prof->{'query_end'}, 'query_end called'); + +DBICTest->schema->txn_commit(); +ok($prof->{'txn_commit'}, 'txn_commit called'); + +$prof->reset(); + +# Test a rollback +DBICTest->schema->txn_begin(); +$rs = DBICTest::CD->search({}); +$rs->count(); +DBICTest->schema->txn_rollback(); +ok($prof->{'txn_rollback'}, 'txn_rollback called'); + +DBICTest->schema->storage->debug(0); + +package DBIx::Test::Profiler; +use strict; + +sub new { + my $self = bless({}); +} + +sub query_start { + my $self = shift(); + $self->{'query_start'} = 1; +} + +sub query_end { + my $self = shift(); + $self->{'query_end'} = 1; +} + +sub txn_begin { + my $self = shift(); + $self->{'txn_begin'} = 1; +} + +sub txn_rollback { + my $self = shift(); + $self->{'txn_rollback'} = 1; +} + +sub txn_commit { + my $self = shift(); + $self->{'txn_commit'} = 1; +} + +sub reset { + my $self = shift(); + + $self->{'query_start'} = 0; + $self->{'query_end'} = 0; + $self->{'txn_begin'} = 0; + $self->{'txn_rollback'} = 0; + $self->{'txn_end'} = 0; +} + +1;