Profile.pm

   1 #
   2 # Version: 1.0
   3 # Jeff Lathan
   4 # Kerry Clendinning
   5 #
   6 # Aaron Lee
   7 #    Deja.com, 10-1999
   8 # Michael G Schwern, 11-1999
   9 #
  10
  11 #  Copyright (c) 1999,2000 Jeff Lathan, Kerry Clendinning.  All rights reserved.
  12 #  This program is free software; you can redistribute it and/or modify it
  13 #  under the same terms as Perl itself.
  14
  15 # .15 First public release.  Bad naming.
  16 # .20 Fixed naming problems
  17 # .30 Module is now more transparent, thanks to Michael G Schwern
  18 #     One less "To Do" left!
  19 #     11-4-1999
  20 # 1.0 Added ability to trace executes, chosen by an environment variable
  21 #     Added capability of saving everything to a log file
  22 #
  23
  24 #
  25 # This package provides an easy way to profile your DBI-based application.
  26 # By just "use"ing this module, you will enable counting and measuring
  27 # realtime and cpu time for each and every query used in the application.
  28 # The times are accumulated by phase: execute vs. fetch, and broken down by
  29 # first fetch, subsequent fetch and failed fetch within each of the
  30 # fetchrow_array, fetchrow_arrayref, and fetchrow_hashref methods.
  31 # More DBI functions will be added in the future.
  32 #
  33 # USAGE:
  34 # Add "use DBIx::Profile;" or use "perl -MDBIx::Profile <program>"
  35 # Add a call to $dbh->printProfile() before calling disconnect,
  36 #    or disconnect will dump the information.
  37 #
  38 # To Do:
  39 #    Make the printProfile code better
  40 #
  41
  42 ##########################################################################
  43 ##########################################################################
  44
  45 =head1 NAME
  46
  47   DBIx::Profile - DBI query profiler
  48   Version 1.0
  49
  50   Copyright (c) 1999,2000 Jeff Lathan, Kerry Clendinning.
  51   All rights reserved.
  52
  53   This program is free software; you can redistribute it and/or modify it
  54   under the same terms as Perl itself.
  55
  56 =head1 SYNOPSIS
  57
  58   use DBIx::Profile; or "perl -MDBIx::Profile <program>"
  59   use DBI;
  60   $dbh->printProfile();
  61
  62 =head1 DESCRIPTION
  63
  64   DBIx::Profile is a quick and easy, and mostly transparent, profiler
  65   for scripts using DBI.  It collects information on the query
  66   level, and keeps track of first, failed, normal, and total amounts
  67   (count, wall clock, cput time) for each function on the query.
  68
  69   NOTE: DBIx::Profile use Time::HiRes to clock the wall time and
  70   the old standby times() to clock the cpu time.  The cpu time is
  71   pretty coarse.
  72
  73   DBIx::Profile can also trace the execution of queries.  It will print
  74   a timestamp and the query that was called.  This is optional, and
  75   occurs only when the environment variable DBIXPROFILETRACE is set
  76   to 1. (ex: (bash) export DBIXPROFILETRACE=1).
  77
  78   Not all DBI methods are profiled at this time.
  79   Except for replacing the existing "use" and "connect" statements,
  80   DBIx::Profile allows DBI functions to be called as usual on handles.
  81
  82   Prints information to STDERR, prefaced with the pid.
  83
  84 =head1 RECIPE
  85
  86   1) Add "use DBIx::Profile" or execute "perl -MDBIx::Profile <program>"
  87   2) Optional: add $dbh->printProfile (will execute during
  88      disconnect otherwise)
  89   3) Run code
  90   4) Data output will happen at printProfile or $dbh->disconnect;
  91
  92 =head1 METHODS
  93
  94   printProfile
  95      $dbh->printProfile();
  96
  97      Will print out the data collected.
  98      If this is not called before disconnect, disconnect will call
  99      printProfile.
 100
 101   setLogFile
 102      $dbh->setLogFile("ProfileOutput.txt");
 103
 104      Will save all output to the file.
 105
 106 =head1 AUTHORS
 107
 108   Jeff Lathan, lathan@pobox.com
 109   Kerry Clendinning, kerry@deja.com
 110
 111   Aaron Lee, aaron@pointx.org
 112   Michael G Schwern, schwern@pobox.com
 113
 114 =head1 SEE ALSO
 115
 116   L<perl(1)>, L<DBI>
 117
 118 =cut
 119
 120 #
 121 # For CPAN and Makefile.PL
 122 #
 123 $VERSION = '1.0';
 124
 125 use DBI;
 126
 127 package DBIx::Profile;
 128
 129 # Store DBI's original connect & disconnect then replace it with ours.
 130 {
 131     local $^W = 0;  # Redefining a subrouting makes noise.
 132     *_DBI_connect = DBI->can('connect');
 133     *DBI::connect = \&connect;
 134 }
 135
 136 use strict;
 137 use vars qw(@ISA);
 138
 139 @ISA = qw(DBI);
 140
 141 #
 142 # Make DBI aware of us.
 143 #
 144 __PACKAGE__->init_rootclass;
 145
 146 $DBIx::Profile::DBIXFILE = "";
 147 $DBIx::Profile::DBIXFILEHANDLE = "";
 148 $DBIx::Profile::DBIXTRACE = 0;
 149
 150 if ($ENV{DBIXPROFILETRACE}) {
 151     $DBIx::Profile::DBIXTRACE = 1;
 152 }
 153
 154 sub connect {
 155     my $self = shift;
 156     my $result = __PACKAGE__->_DBI_connect(@_);
 157
 158     if ($result ) {
 159         # set flag so we know if we have not printed profile data
 160         $result->{'private_profile'}->{'printProfileFlag'} = 0;
 161     }
 162
 163     return $result;
 164 }
 165
 166 ##########################################################################
 167 ##########################################################################
 168
 169 package DBIx::Profile::db;
 170 use strict;
 171 use vars qw(@ISA );
 172
 173 @ISA = qw( DBI::db );
 174
 175 #
 176 # insert our "hooks" to grab subsequent calls
 177 #
 178 sub prepare {
 179
 180     my $self = shift;
 181
 182     my $result = $self->SUPER::prepare(@_);
 183
 184     if ($result) {
 185         $result->initRef();
 186     }
 187
 188     return ($result);
 189 }
 190
 191 #
 192 # disconnect from the database; if printProfile has not been called, call it.
 193 #
 194 sub disconnect {
 195     my $self = shift;
 196
 197     if ( !$self->{'private_profile'}->{'printProfileFlag'}) {
 198         $self->printProfile;
 199     }
 200
 201     return $self->SUPER::disconnect(@_);
 202 }
 203
 204 sub setLogFile {
 205     my $self = shift;
 206     my $logName = shift;
 207
 208     $DBIx::Profile::DBIXFILE = $logName;
 209
 210     open(OUT,">$logName") || die "Could not open file!";
 211
 212     $DBIx::Profile::DBIXFILEHANDLE = \*OUT;
 213
 214     return 1;
 215 }
 216
 217 sub DESTROY {
 218     my $self = shift;
 219     $self->disconnect(@_);
 220 }
 221
 222 #
 223 # Print the data collected.
 224 #
 225 # JEFF - The printing and the print code is kinda (er... very) ugly!
 226 #
 227
 228 sub printProfile {
 229
 230     my $self = shift;
 231     my %result;
 232     my $total = 0;
 233     no integer;
 234
 235     # Set that we have printed the results
 236     $self->{'private_profile'}->{'printProfileFlag'} = 1;
 237
 238     # Loop through the queries
 239     foreach my $qry (keys %{$self->{'private_profile'}}) {
 240
 241         my $text = "";
 242
 243         if ( $qry eq "printProfileFlag" ) {
 244             next;
 245         }
 246
 247         $total = 0;
 248
 249         # Now loop through the actions (execute, fetchrow, etc)
 250         foreach my $name ( sort keys %{$self->{'private_profile'}->{$qry}}) {
 251             # Right now, this assumes that we only have wall clock, cpu
 252             # and count.  Not generic, but what we want NOW
 253
 254             if ( $name eq "first" ) {
 255                 next;
 256             }
 257
 258             $text .= "   $name ---------------------------------------\n";
 259
 260             foreach my $type (sort keys %{$self->{'private_profile'}->{$qry}->{$name}}) {
 261                 $text .= "      $type\n";
 262
 263                 my ($count, $time, $ctime);
 264                 $count = $self->{'private_profile'}->{$qry}->{$name}->{$type}->{'count'};
 265                 $time = $self->{'private_profile'}->{$qry}->{$name}->{$type}->{'realtime'};
 266                 $ctime = $self->{'private_profile'}->{$qry}->{$name}->{$type}->{'cputime'};
 267
 268                 $text .= sprintf "         Count        : %10d\n",$count;
 269                 $text .= sprintf "         Wall Clock   : %10.7f s   %10.7f s\n",$time,$time/$count;
 270                 $text .= sprintf "         Cpu Time     : %10.7f s   %10.7f s\n",$ctime,$ctime/$count;
 271
 272                 if ($type eq "Total") {
 273                     $total += $time;
 274                 }
 275
 276             } # $type
 277         } # $name
 278
 279         $text = "$$ \"" . $qry . "\"   Total wall clock time: ". $total ."s \n" . $text;
 280         $text = "=================================================================\n" . $text;
 281
 282         # In order to sort based on the total time taken for a query "easily"
 283         # we are placing the information in a hash with the total time as the key.
 284         # Since we could have many queries with the same total, if this exists,
 285         # we cat the query string to the total string and use that as the key.
 286         # The sort function will do the right thing.
 287
 288         if (exists $result{$total} ) {
 289             $total .= $qry;
 290         }
 291
 292         $result{$total} = $text;
 293     } # each query
 294
 295     foreach my $qry (sort stripsort keys %result) {
 296         if ($DBIx::Profile::DBIXFILE eq "" ) {
 297             warn $result{$qry} . "\n";
 298         } else {
 299             print $DBIx::Profile::DBIXFILEHANDLE $result{$qry} . "\n";
 300         }
 301     }
 302 }
 303
 304 sub stripsort {
 305
 306     # Strip off the actual number amount, since the variables may
 307     # contain text as well
 308
 309     $a =~ m/^(\d+\.\d+)/;
 310     my $na = $1;
 311     $b =~ m/^(\d+\.\d+)/;
 312     my $nb = $1;
 313
 314     # Yes, this processes backwards since we want to go decreasing
 315     $nb <=> $na;
 316
 317 }
 318
 319 ##########################################################################
 320 ##########################################################################
 321
 322 package DBIx::Profile::st;
 323 use strict;
 324 use vars qw(@ISA);
 325
 326 @ISA = qw(DBI::st);
 327
 328 # Get some accurancy for wall clock time
 329 # Cpu time is still very coarse, but...
 330
 331 use Time::HiRes qw ( gettimeofday tv_interval);
 332
 333 # Aaron Lee (aaron@pointx.org) provided the majority of
 334 # BEGIN block below.  It allowed the removal of a lot of duplicate code
 335 # and makes the code much much cleaner, and easier to add DBI functionality.
 336
 337 BEGIN {
 338
 339     # Basic idea for each timing function:
 340     # Grab timing info
 341     # Call real DBI call
 342     # Grab timing info
 343     # Calculate time diff
 344     #
 345     # Just add more functions in @func_list
 346
 347     my @func_list = ('fetchrow_array','fetchrow_arrayref','execute',
 348                      'fetchrow_hashref');
 349
 350     my $func;
 351
 352     foreach $func (@func_list){
 353
 354         # define subroutine code, incl dynamic name and SUPER:: call
 355         my $sub_code =
 356             "sub $func {" . '
 357                 my $self = shift;
 358                 my @result;
 359                 my $result;
 360                 my ($time, $ctime, $temp, $x, $y, $z, $type);
 361
 362                 if (wantarray) {
 363
 364                    $time = [gettimeofday];
 365                    ($ctime, $x ) = times();
 366
 367                    @result =  $self->SUPER::' . "$func" . '(@_);
 368
 369                    ($y, $z ) = times();
 370                    $time = tv_interval ($time, [gettimeofday]);
 371
 372                    #
 373                    # Checking scalar because we are also interested
 374                    # in catching empty list
 375                    #
 376                    if (scalar @result) {
 377                       $type = "normal";
 378                    } else {
 379                       if (!$self->err) {
 380                          $type = "no more rows";
 381                       } else {
 382                          $type = "error";
 383                       }
 384                    }
 385
 386                    $ctime = ($y + $z) - ($x + $ctime);
 387                    $self->increment($func,$type,$time, $ctime);
 388                    return @result;
 389
 390                 } else {
 391
 392                    $time = [gettimeofday];
 393                    ($ctime, $x ) = times();
 394
 395                    $result =  $self->SUPER::' . "$func" . '(@_);
 396
 397                    ($y, $z ) = times();
 398                    $time = tv_interval ($time, [gettimeofday]);
 399
 400                    if (defined $result) {
 401                       if ($result ne "0E0") {
 402                          $type = "normal";
 403                       } else {
 404                          $type = "returned 0E0";
 405                       }
 406
 407                    } else {
 408                       if (!$self->err) {
 409                          $type = "no more rows";
 410                       } else {
 411                          $type = "error";
 412                       }
 413                    }
 414
 415                    $ctime = ($y + $z) - ($x + $ctime);
 416                    $self->increment($func,$type,$time, $ctime);
 417                    return $result;
 418
 419                 } # end of if (wantarray);
 420
 421             } # end of function definition
 422         ';
 423
 424         # define $func in current package
 425         eval $sub_code;
 426     }
 427 }
 428
 429 sub fetchrow {
 430     my $self = shift;
 431     #
 432     # fetchrow is just an alias for fetchrow_array, so
 433     # send it that way
 434     #
 435     # Is the return below safe, given the main function above? - JEFF
 436     #
 437
 438     return $self->fetchrow_array(@_);
 439 }
 440
 441 sub increment {
 442     my ($self, $name, $type, $time, $ctime) = @_;
 443
 444     my $ref;
 445     my $qry = $self->{'Statement'};
 446     $ref = $self->{'private_profile'};
 447
 448     # text matching?!?  *sigh* - JEFF
 449     if ( $name =~ /^execute/ ) {
 450         $ref->{"first"} = 1;
 451         if ( $DBIx::Profile::DBIXTRACE ) {
 452             my ($sec, $min, $hour, $mday, $mon);
 453             ($sec, $min, $hour, $mday, $mon) = localtime(time);
 454             my $text = sprintf("%d-%2d %2d:%2d:%2d", $mon, $mday,$hour,$min,$sec);
 455             if ($DBIx::Profile::DBIXFILE eq "" ) {
 456                 warn "$$ text $name SQL: $qry\n";
 457             } else {
 458                 print $DBIx::Profile::DBIXFILEHANDLE "$$ $text $name SQL: $qry\n";
 459             }
 460         }
 461     }
 462
 463     if ( ($name =~ /^fetch/) && ($ref->{'first'} == 1) ) {
 464         $type = "first";
 465         $ref->{'first'} = 0;
 466     }
 467
 468     $ref->{$name}->{$type}->{'count'}++;
 469     $ref->{$name}->{$type}->{'realtime'}+= $time;
 470     $ref->{$name}->{$type}->{'cputime'}+= $ctime;
 471
 472     $ref->{$name}->{"Total"}->{'count'}++;
 473     $ref->{$name}->{"Total"}->{'realtime'}+= $time;
 474     $ref->{$name}->{"Total"}->{'cputime'}+= $ctime;
 475
 476 }
 477
 478 # initRef is called from Prepare in DBIProfile
 479 #
 480 # Its purpose is to create the DBI's private_profile info
 481 # so that we do not lose DBI::errstr in increment() later
 482
 483 sub initRef {
 484     my $self = shift;
 485     my $qry = $self->{'Statement'};
 486
 487     if (!exists($self->{'private_profile'})) {
 488         if (!exists($self->{'Database'}->{'private_profile'}->{$qry})) {
 489             $self->{'Database'}->{'private_profile'}->{$qry} = {};
 490         }
 491         $self->{'private_profile'} =
 492             $self->{'Database'}->{'private_profile'}->{$qry};
 493     }
 494 }
 495
 496 1;
 497
 498
 499
 500
 501
 502