From: Cory G Watson <gphat@cpan.org>
Date: Mon, 15 May 2006 17:46:01 +0000 (+0000)
Subject: Add profiling support
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4c24816137de09c629fcd3da41b7626d50cc13f6;p=dbsrgits%2FDBIx-Class-Historic.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 <gphat@cpan.org>
+
 =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<DBIx::Class::Storage::DBI>'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<DBIx::Class::Storage::Statistics> 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<debugfh> filehandle
-(or C<STDERR> if C<debugfh> has not specifically been set).
+Causes SQL trace information to be emitted on the C<debugobj> object.
+(or C<STDERR> if C<debugobj> 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<print> 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<print> method is used.  Initially
+set to be STDERR - although see information on the
 L<DBIX_CLASS_STORAGE_DBI_DEBUG> environment variable.
 
+=head2 debugobj
+
+Sets or retrieves the object used for metric collection. Defaults to an instance
+of L<DBIx::Class::Storage::Statistics> 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<debugobj> 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<DBIx::Class::Manual::Cookbook>.
+
+=head1 METHODS
+
+=cut
+
+=head2 new
+
+Returns a new L<DBIx::Class::Storage::Statistics> 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<print> method is used). Initially
+should be set to STDERR - although see information on the
+L<DBIX_CLASS_STORAGE_DBI_DEBUG> 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 <gphat@cpan.org>
+
+=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;