Profile.pm

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