#
# Version: 1.01
# Jeff Lathan
# Kerry Clendinning
#
# Aaron Lee
#    Deja.com, 10-1999
# Michael G Schwern, 11-1999
#
# Current maintainer: Ivan Kohler <ivan-dbix-profile@420.am>

#  Copyright (c) 1999,2000 Jeff Lathan, Kerry Clendinning.  All rights reserved. 
#  This program is free software; you can redistribute it and/or modify it 
#  under the same terms as Perl itself.

# .15 First public release.  Bad naming.
# .20 Fixed naming problems
# .30 Module is now more transparent, thanks to Michael G Schwern
#     One less "To Do" left!
#     11-4-1999
# 1.0 Added ability to trace executes, chosen by an environment variable
#     Added capability of saving everything to a log file
# 1.01 Added sprintf patch, MANIFEST and Changes files, and kludge to get
#      along with DBIx::ContextualFetch

#
# This package provides an easy way to profile your DBI-based application.
# By just "use"ing this module, you will enable counting and measuring
# realtime and cpu time for each and every query used in the application.
# The times are accumulated by phase: execute vs. fetch, and broken down by
# first fetch, subsequent fetch and failed fetch within each of the 
# fetchrow_array, fetchrow_arrayref, and fetchrow_hashref methods.  
# More DBI functions will be added in the future.
# 
# USAGE:
# Add "use DBIx::Profile;" or use "perl -MDBIx::Profile <program>"
# Add a call to $dbh->printProfile() before calling disconnect,
#    or disconnect will dump the information.
#
# To Do:
#    Make the printProfile code better
#    

##########################################################################
##########################################################################

=head1 NAME

  DBIx::Profile - DBI query profiler
  Version 1.01

  Copyright (c) 1999,2000 Jeff Lathan, Kerry Clendinning.  
  All rights reserved. 

  This program is free software; you can redistribute it and/or modify it 
  under the same terms as Perl itself.

=head1 SYNOPSIS

  use DBIx::Profile; or "perl -MDBIx::Profile <program>" 
  use DBI;
  $dbh->printProfile();

  #or to use with things like like to be the DBI root class themselves:
  # (Class::DBI / Ima::DBI uses DBIx::ContextualFetch)
  use DBIx::Profile ( RootClass=>'DBIx::ContextualFetch' );

=head1 DESCRIPTION

  DBIx::Profile is a quick and easy, and mostly transparent, profiler
  for scripts using DBI.  It collects information on the query 
  level, and keeps track of first, failed, normal, and total amounts
  (count, wall clock, cput time) for each function on the query.

  NOTE: DBIx::Profile use Time::HiRes to clock the wall time and
  the old standby times() to clock the cpu time.  The cpu time is
  pretty coarse.

  DBIx::Profile can also trace the execution of queries.  It will print 
  a timestamp and the query that was called.  This is optional, and 
  occurs only when the environment variable DBIXPROFILETRACE is set 
  to 1. (ex: (bash) export DBIXPROFILETRACE=1).

  Not all DBI methods are profiled at this time.
  Except for replacing the existing "use" and "connect" statements,
  DBIx::Profile allows DBI functions to be called as usual on handles.

  Prints information to STDERR, prefaced with the pid.

=head1 RECIPE

  1) Add "use DBIx::Profile" or execute "perl -MDBIx::Profile <program>"
  2) Optional: add $dbh->printProfile (will execute during 
     disconnect otherwise)
  3) Run code
  4) Data output will happen at printProfile or $dbh->disconnect;

=head1 METHODS

  printProfile
     $dbh->printProfile();

     Will print out the data collected.
     If this is not called before disconnect, disconnect will call
     printProfile.

  sprintProfile
     $profile = $dbh->sprintPRofile();

     Returns the data collected.

  setLogFile
     $dbh->setLogFile("ProfileOutput.txt");

     Will save all output to the file.

=head1 AUTHORS

  Jeff Lathan, lathan@pobox.com
  Kerry Clendinning, kerry@deja.com

  Aaron Lee, aaron@pointx.org
  Michael G Schwern, schwern@pobox.com

  Current maintainer: Ivan Kohler <ivan-dbix-profile@420.am>

=head1 SEE ALSO

  L<perl(1)>, L<DBI>

=cut

package DBIx::Profile;

use strict;
use vars qw(@ISA $VERSION);
use DBI;

$VERSION = '1.01';

@ISA = qw(DBI);

# Store DBI's original connect & disconnect then replace it with ours.
{
    local $^W = 0;  # Redefining a subrouting makes noise.
    *_DBI_connect = DBI->can('connect');
    *DBI::connect = \&connect;
}

#
# Make DBI aware of us.
#
__PACKAGE__->init_rootclass;

$DBIx::Profile::DBIXFILE = "";
$DBIx::Profile::DBIXFILEHANDLE = "";
$DBIx::Profile::DBIXTRACE = 0;

if ($ENV{DBIXPROFILETRACE}) {
    $DBIx::Profile::DBIXTRACE = 1;
}

sub import {
  my( $self, %opt ) = @_;
  if ( $opt{RootClass} ) {
    eval "use $opt{RootClass}";
    #*_DBI_connect = UNIVERSAL::can( $opt{'RootClass'}, 'connect' );
    #*DBI::connect = \&connect;
    unshift @DBIx::Profile::ISA, $opt{RootClass};
    unshift @DBIx::Profile::db::ISA, $opt{RootClass}. '::db';
    unshift @DBIx::Profile::st::ISA, $opt{RootClass}. '::st';
    #__PACKAGE__->init_rootclass;
  }
}

sub connect {
    my $self = shift;
    my $result = __PACKAGE__->_DBI_connect(@_);

    if ($result ) {
	# set flag so we know if we have not printed profile data
	$result->{'private_profile'}->{'printProfileFlag'} = 0;
    }

    return $result;
}

##########################################################################
##########################################################################

package DBIx::Profile::db;
use strict;
use vars qw(@ISA );

@ISA = qw( DBI::db );

# 
# insert our "hooks" to grab subsequent calls
#
sub prepare {

    my $self = shift;
    
    my $result = $self->SUPER::prepare(@_);

    if ($result) {
	$result->initRef();
    } 

    return ($result);
}

# 
# disconnect from the database; if printProfile has not been called, call it.
#
sub disconnect {
    my $self = shift;

    if ( !$self->{'private_profile'}->{'printProfileFlag'}) {
	$self->printProfile;
    }

    return $self->SUPER::disconnect(@_);
}

sub setLogFile { 
    my $self = shift;
    my $logName = shift;

    $DBIx::Profile::DBIXFILE = $logName;

    open(OUT,">$logName") || die "Could not open file!";

    $DBIx::Profile::DBIXFILEHANDLE = \*OUT;

    return 1;
}

sub DESTROY {
    my $self = shift;
    $self->disconnect(@_);
}

#
# Print the data collected.
#
# JEFF - The printing and the print code is kinda (er... very) ugly!
#

#like printProfile, except returns the results instead of printing them.
sub sprintProfile {
    my $self = shift;
    $self->printProfile({'sprint'=>1});
}

sub printProfile {

    my $self = shift;
    my $args = shift;
    my %result;
    my $total = 0;
    no integer;

    # Set that we have printed the results
    $self->{'private_profile'}->{'printProfileFlag'} = 1;

    # Loop through the queries
    foreach my $qry (keys %{$self->{'private_profile'}}) {

	my $text = "";

	if ( $qry eq "printProfileFlag" ) {
	    next;
	}

	$total = 0;

	# Now loop through the actions (execute, fetchrow, etc)
	foreach my $name ( sort keys %{$self->{'private_profile'}->{$qry}}) {
	    # Right now, this assumes that we only have wall clock, cpu
	    # and count.  Not generic, but what we want NOW
   
	    if ( $name eq "first" ) {
		next;
	    }

	    $text .= "   $name ---------------------------------------\n";

	    foreach my $type (sort keys %{$self->{'private_profile'}->{$qry}->{$name}}) {
		$text .= "      $type\n";
		
		my ($count, $time, $ctime);
		$count = $self->{'private_profile'}->{$qry}->{$name}->{$type}->{'count'};
		$time = $self->{'private_profile'}->{$qry}->{$name}->{$type}->{'realtime'};
		$ctime = $self->{'private_profile'}->{$qry}->{$name}->{$type}->{'cputime'};
		
		$text .= sprintf "         Count        : %10d\n",$count;
		$text .= sprintf "         Wall Clock   : %10.7f s   %10.7f s\n",$time,$time/$count;
		$text .= sprintf "         Cpu Time     : %10.7f s   %10.7f s\n",$ctime,$ctime/$count;

		if ($type eq "Total") {
		    $total += $time;
		}
		
	    } # $type
	} # $name

	$text = "$$ \"" . $qry . "\"   Total wall clock time: ". $total ."s \n" . $text;
	$text = "=================================================================\n" . $text;

	# In order to sort based on the total time taken for a query "easily"
	# we are placing the information in a hash with the total time as the key.
	# Since we could have many queries with the same total, if this exists,
	# we cat the query string to the total string and use that as the key.
	# The sort function will do the right thing.

	if (exists $result{$total} ) {
	    $total .= $qry;
	}

	$result{$total} = $text;
    } # each query

    my $results;
    foreach my $qry (sort stripsort keys %result) {
        if ( $args->{'sprint'} ) {
            $results .= $result{$qry} . "\n";
        } elsif ($DBIx::Profile::DBIXFILE eq "" ) {
	    warn $result{$qry} . "\n";
	} else {
	    print $DBIx::Profile::DBIXFILEHANDLE $result{$qry} . "\n";
	}
    }

    return $results if $args->{'sprint'};
}
    
sub stripsort {

    # Strip off the actual number amount, since the variables may
    # contain text as well

    $a =~ m/^(\d+\.\d+)/;
    my $na = $1;
    $b =~ m/^(\d+\.\d+)/;
    my $nb = $1;
    
    # Yes, this processes backwards since we want to go decreasing
    $nb <=> $na;

}

##########################################################################
##########################################################################

package DBIx::Profile::st;
use strict;
use vars qw(@ISA);

@ISA = qw(DBI::st);

# Get some accurancy for wall clock time
# Cpu time is still very coarse, but...

use Time::HiRes qw ( gettimeofday tv_interval);

# Aaron Lee (aaron@pointx.org) provided the majority of
# BEGIN block below.  It allowed the removal of a lot of duplicate code
# and makes the code much much cleaner, and easier to add DBI functionality.

BEGIN {

    # Basic idea for each timing function:
    # Grab timing info
    # Call real DBI call
    # Grab timing info
    # Calculate time diff
    # 
    # Just add more functions in @func_list

    my @func_list = ('fetchrow_array','fetchrow_arrayref','execute', 
		     'fetchrow_hashref');
    
    my $func;

    foreach $func (@func_list){
	
	# define subroutine code, incl dynamic name and SUPER:: call 
	my $sub_code = 
	    "sub $func {" . '
		my $self = shift;
		my @result; 
                my $result;
		my ($time, $ctime, $temp, $x, $y, $z, $type);

                if (wantarray) {

                   $time = [gettimeofday];
		   ($ctime, $x ) = times();

                   @result =  $self->SUPER::' . "$func" . '(@_); 
	
		   ($y, $z ) = times();
		   $time = tv_interval ($time, [gettimeofday]);

                   #
                   # Checking scalar because we are also interested
                   # in catching empty list
                   #
                   if (scalar @result) {
                      $type = "normal";
                   } else {
                      if (!$self->err) {
                         $type = "no more rows";
                      } else {
                         $type = "error";
                      }
                   }

		   $ctime = ($y + $z) - ($x + $ctime);
                   $self->increment($func,$type,$time, $ctime);
                   return @result;

                } else {

		   $time = [gettimeofday];
		   ($ctime, $x ) = times();

                   $result =  $self->SUPER::' . "$func" . '(@_); 
	
		   ($y, $z ) = times();
		   $time = tv_interval ($time, [gettimeofday]);

                   if (defined $result) {
                      if ($result ne "0E0") {
                         $type = "normal";
                      } else {
                         $type = "returned 0E0";
                      }

                   } else {
                      if (!$self->err) {
                         $type = "no more rows";
                      } else {
                         $type = "error";
                      }
                   }

		   $ctime = ($y + $z) - ($x + $ctime);
                   $self->increment($func,$type,$time, $ctime);
                   return $result;

                } # end of if (wantarray);

	    } # end of function definition
        ';
	
	# define $func in current package
	eval $sub_code;
    }
}

sub fetchrow {
    my $self = shift;
    #
    # fetchrow is just an alias for fetchrow_array, so
    # send it that way
    #
    # Is the return below safe, given the main function above? - JEFF
    #

    return $self->fetchrow_array(@_);
}

sub increment {
    my ($self, $name, $type, $time, $ctime) = @_;

    my $ref;
    my $qry = $self->{'Statement'};
    $ref = $self->{'private_profile'};

    # text matching?!?  *sigh* - JEFF
    if ( $name =~ /^execute/ ) {
	$ref->{"first"} = 1;
	if ( $DBIx::Profile::DBIXTRACE ) {
	    my ($sec, $min, $hour, $mday, $mon);
	    ($sec, $min, $hour, $mday, $mon) = localtime(time);
	    my $text = sprintf("%d-%2d %2d:%2d:%2d", $mon, $mday,$hour,$min,$sec);
	    if ($DBIx::Profile::DBIXFILE eq "" ) {
		warn "$$ text $name SQL: $qry\n";
	    } else {
		print $DBIx::Profile::DBIXFILEHANDLE "$$ $text $name SQL: $qry\n";
	    }
	}
    }

    if ( ($name =~ /^fetch/) && ($ref->{'first'} == 1) ) {
	$type = "first";
	$ref->{'first'} = 0;
    }

    $ref->{$name}->{$type}->{'count'}++;
    $ref->{$name}->{$type}->{'realtime'}+= $time;
    $ref->{$name}->{$type}->{'cputime'}+= $ctime;

    $ref->{$name}->{"Total"}->{'count'}++;
    $ref->{$name}->{"Total"}->{'realtime'}+= $time;
    $ref->{$name}->{"Total"}->{'cputime'}+= $ctime;
    
}

# initRef is called from Prepare in DBIProfile
#
# Its purpose is to create the DBI's private_profile info
# so that we do not lose DBI::errstr in increment() later

sub initRef {
    my $self = shift;
    my $qry = $self->{'Statement'};

    if (!exists($self->{'private_profile'})) {
	if (!exists($self->{'Database'}->{'private_profile'}->{$qry})) {
	    $self->{'Database'}->{'private_profile'}->{$qry} = {};
        }
        $self->{'private_profile'} = 
	    $self->{'Database'}->{'private_profile'}->{$qry};    
    }
}

1;