profile.pm

SinFP是一种新的识别对方计算机操作系统类型的工具

to write them to the DBI trace() filehandle (which defaults to
STDERR). To direct the DBI trace filehandle to write to a file
without enabling tracing the trace() method can be called with a
trace level of 0. For example:

    DBI->trace(0, $filename);

The same effect can be achieved without changing the code by
setting the C<DBI_TRACE> environment variable to C<0=filename>.

The $DBI::Profile::ON_DESTROY_DUMP variable holds a code ref
that's called to perform the output of the formatted results.
The default value is:

  $ON_DESTROY_DUMP = sub { DBI->trace_msg($results, 0) };

Apart from making it easy to send the dump elsewhere, it can also
be useful as a simple way to disable dumping results.

=head1 CHILD HANDLES

Child handles inherit a reference to the Profile attribute value
of their parent.  So if profiling is enabled for a database handle
then by default the statement handles created from it all contribute
to the same merged profile data tree.


=head1 CUSTOM DATA MANIPULATION

Recall that C<$h->{Profile}->{Data}> is a reference to the collected data.
Either to a 'leaf' array (when the Path is empty, i.e., DBI_PROFILE env var is 1),
or a reference to hash containing values that are either further hash
references or leaf array references.

Sometimes it's useful to be able to summarise some or all of the collected data.
The dbi_profile_merge() function can be used to merge leaf node values.

=head2 dbi_profile_merge

  use DBI qw(dbi_profile_merge);

  $time_in_dbi = dbi_profile_merge(my $totals=[], @$leaves);

Merges profile data node. Given a reference to a destination array, and zero or
more references to profile data, merges the profile data into the destination array.
For example:

  $time_in_dbi = dbi_profile_merge(
      my $totals=[],
      [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
      [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
  );        

$totals will then contain

  [ 25, 0.93, 0.11, 0.01, 0.23, 1023110000, 1023110010 ]

and $time_in_dbi will be 0.93;

For example, to get the time spent 'inside' the DBI during an http request,
your logging code run at the end of the request (i.e. mod_perl LogHandler)
could use:

  my $time_in_dbi = 0;
  if (my $Profile = $dbh->{Profile}) { # if DBI profiling is enabled
      $time_in_dbi = dbi_profile_merge(my $total=[], $Profile->{Data});
      $Profile->{Data} = {}; # reset the profile data
  }

If profiling has been enabled then $time_in_dbi will hold the time spent inside
the DBI for that handle (and any other handles that share the same profile data)
since the last request.

=head1 CUSTOM DATA COLLECTION

=head2 Using The Path Attribute

  XXX example to be added later using a selectall_arrayref call
  XXX nested inside a fetch loop where the first column of the
  XXX outer loop is bound to the profile Path using
  XXX bind_column(1, \${ $dbh->{Profile}->{Path}->[0] })
  XXX so you end up with separate profiles for each loop
  XXX (patches welcome to add this to the docs :)

=head2 Adding Your Own Samples

The dbi_profile() function can be used to add extra sample data
into the profile data tree. For example:

    use DBI;
    use DBI::Profile (dbi_profile dbi_time);

    my $t1 = dbi_time(); # floating point high-resolution time

    ... execute code you want to profile here ...

    my $t2 = dbi_time();
    dbi_profile($h, $statement, $method, $t1, $t2);

The $h parameter is the handle the extra profile sample should be
associated with. The $statement parameter is the string to use where
the Path specifies DBIprofile_Statement. If $statement is undef
then $h->{Statement} will be used. Similarly $method is the string
to use if the Path specifies DBIprofile_MethodName. There is no
default value for $method.

The $h->{Profile}{Path} attribute is processed by dbi_profile() in
the usual way.

It is recommended that you keep these extra data samples separate
from the DBI profile data samples by using values for $statement
and $method that are distinct from any that are likely to appear
in the profile data normally.


=head1 SUBCLASSING

Alternate profile modules must subclass DBI::Profile to help ensure
they work with future versions of the DBI.


=head1 CAVEATS

Applications which generate many different statement strings
(typically because they don't use placeholders) and profile with
DBIprofile_Statement in the Path (the default) will consume memory
in the Profile Data structure for each statement.

If a method throws an exception itself (not via RaiseError) then
it won't be counted in the profile.

If a HandleError subroutine throws an exception (rather than returning
0 and letting RaiseError do it) then the method call won't be counted
in the profile.

Time spent in DESTROY is added to the profile of the parent handle.

Time spent in DBI->*() methods is not counted. The time spent in
the driver connect method, $drh->connect(), when it's called by
DBI->connect is counted if the DBI_PROFILE environment variable is set.

Time spent fetching tied variables, $DBI::errstr, is counted.

DBI::PurePerl does not support profiling (though it could in theory).

A few platforms don't support the gettimeofday() high resolution
time function used by the DBI (and available via the dbi_time() function).
In which case you'll get integer resolution time which is mostly useless.

On Windows platforms the dbi_time() function is limited to millisecond
resolution. Which isn't sufficiently fine for our needs, but still
much better than integer resolution. This limited resolution means
that fast method calls will often register as taking 0 time. And
timings in general will have much more 'jitter' depending on where
within the 'current millisecond' the start and and timing was taken.

This documentation could be more clear. Probably needs to be reordered
to start with several examples and build from there.  Trying to
explain the concepts first seems painful and to lead to just as
many forward references.  (Patches welcome!)

=cut


use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $ON_DESTROY_DUMP);
use Exporter ();
use UNIVERSAL ();
use Carp;

use DBI qw(dbi_time dbi_profile dbi_profile_merge);

$VERSION = sprintf "%d.%02d", '$Revision: 1.7 $ ' =~ /(\d+)\.(\d+)/;

@ISA = qw(Exporter);
@EXPORT = qw(
    DBIprofile_Statement
    DBIprofile_MethodName
    DBIprofile_MethodClass
    dbi_profile
    dbi_profile_merge
    dbi_time
);
@EXPORT_OK = qw(
    format_profile_thingy
);

use constant DBIprofile_Statement	=> -2100000001;
use constant DBIprofile_MethodName	=> -2100000002;
use constant DBIprofile_MethodClass	=> -2100000003;

$ON_DESTROY_DUMP = sub { DBI->trace_msg(shift, 0) };

sub new {
    my $class = shift;
    my $profile = { @_ };
    return bless $profile => $class;
}


sub _auto_new {
    my $class = shift;
    my ($arg) = @_;

    # This sub is called by DBI internals when a non-hash-ref is
    # assigned to the Profile attribute. For example
    #	dbi:mysql(RaiseError=>1,Profile=>4/DBIx::MyProfile):dbname
    # This sub works out what to do and returns a suitable hash ref.
    
    my ($path, $module, @args);

    # parse args
    if ($arg =~ m!/!) {
        # it's a path/module/arg/arg/arg list
        ($path, $module, @args) = split /\s*\/\s*/, $arg, -1;
    } elsif ($arg =~ /^\d+$/) {
        # it's a numeric path selector
        $path = $arg;
    } else {
        # it's a module name
        $module = $arg;
    }

    my @Path;
    if ($path) {
	my $reverse = ($path < 0) ? ($path=-$path, 1) : 0;
	push @Path, "DBI"			if $path & 0x01;
	push @Path, DBIprofile_Statement	if $path & 0x02;
	push @Path, DBIprofile_MethodName	if $path & 0x04;
	push @Path, DBIprofile_MethodClass	if $path & 0x08;
	@Path = reverse @Path if $reverse;
    } else {
        # default Path
        push @Path, DBIprofile_Statement;
    }

    if ($module) {
	if (eval "require $module") {
	  $class = $module;
	}
	else {
	    carp "Can't use $module for DBI profile: $@";
	}
    }

    return $class->new(Path => \@Path, @args);
}


sub format {
    my $self = shift;
    my $class = ref($self) || $self;
    
    my $prologue = "$class: ";
    my $detail = $self->format_profile_thingy(
	$self->{Data}, 0, "    ",
	my $path = [],
	my $leaves = [],
    )."\n";

    if (@$leaves) {
	dbi_profile_merge(my $totals=[], @$leaves);
	my ($count, $dbi_time) = @$totals;
	(my $progname = $0) =~ s:.*/::;
	if ($count) {
	    $prologue .= sprintf "%fs ", $dbi_time;
	    my $perl_time = dbi_time() - $^T;
	    $prologue .= sprintf "%.2f%% ", $dbi_time/$perl_time*100
		if $DBI::PERL_ENDING && $perl_time;
	    my @lt = localtime(time);
	    my $ts = sprintf "%d-%02d-%02d %02d:%02d:%02d",
		1900+$lt[5], $lt[4]+1, @lt[3,2,1,0];
	    $prologue .= sprintf "(%d calls) $progname \@ $ts\n", $count;
	}

	if (@$leaves == 1 && $self->{Data}->{DBI}) {
	    $detail = "";	# hide it
	}
    }
    return ($prologue, $detail) if wantarray;
    return $prologue.$detail;
}


sub format_profile_leaf {
    my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
    croak "format_profile_leaf called on non-leaf ($thingy)"
	unless UNIVERSAL::isa($thingy,'ARRAY');

    push @$leaves, $thingy if $leaves;
    if (0) {
	use Data::Dumper;
	return Dumper($thingy);
    }
    my ($count, $total_time, $first_time, $min, $max, $first_called, $last_called) = @$thingy;
    return sprintf "%s%fs\n", ($pad x $depth), $total_time
	if $count <= 1;
    return sprintf "%s%fs / %d = %fs avg (first %fs, min %fs, max %fs)\n",
	($pad x $depth), $total_time, $count, $count ? $total_time/$count : 0,
	$first_time, $min, $max;
}


sub format_profile_branch {
    my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
    croak "format_profile_branch called on non-branch ($thingy)"
	unless UNIVERSAL::isa($thingy,'HASH');
    my @chunk;
    my @keys = sort keys %$thingy;
    while ( @keys ) {
	my $k = shift @keys;
	my $v = $thingy->{$k};
	push @$path, $k;
	push @chunk, sprintf "%s'%s' =>\n%s",
	    ($pad x $depth), $k,
	    $self->format_profile_thingy($v, $depth+1, $pad, $path, $leaves);
	pop @$path;
    }
    return join "", @chunk;
}


sub format_profile_thingy {
    my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
    return $self->format_profile_leaf(  $thingy, $depth, $pad, $path, $leaves)
	if UNIVERSAL::isa($thingy,'ARRAY');
    return $self->format_profile_branch($thingy, $depth, $pad, $path, $leaves)
	if UNIVERSAL::isa($thingy,'HASH');
    return "$thingy\n";
}


sub on_destroy {
    my $self = shift;
    return unless $ON_DESTROY_DUMP;
    return unless $self->{Data};
    my $detail = $self->format();
    $ON_DESTROY_DUMP->($detail) if $detail;
}

sub DESTROY {
    my $self = shift;
    local $@;
    eval { $self->on_destroy };
    if ($@) {
        my $class = ref($self) || $self;
        DBI->trace_msg("$class on_destroy failed: $@", 0);
    }
}

1;