22

✏️ Editing: ProfileData.pm

package DBI::ProfileData;
use strict;

=head1 NAME

DBI::ProfileData - manipulate DBI::ProfileDumper data dumps

=head1 SYNOPSIS

The easiest way to use this module is through the dbiprof frontend
(see L<dbiprof> for details):

dbiprof --number 15 --sort count

This module can also be used to roll your own profile analysis:

# load data from dbi.prof
  $prof = DBI::ProfileData->new(File => "dbi.prof");

# get a count of the records (unique paths) in the data set
  $count = $prof->count();

# sort by longest overall time
  $prof->sort(field => "longest");

# sort by longest overall time, least to greatest
  $prof->sort(field => "longest", reverse => 1);

# exclude records with key2 eq 'disconnect'
  $prof->exclude(key2 => 'disconnect');

# exclude records with key1 matching /^UPDATE/i
  $prof->exclude(key1 => qr/^UPDATE/i);

# remove all records except those where key1 matches /^SELECT/i
  $prof->match(key1 => qr/^SELECT/i);

# produce a formatted report with the given number of items
  $report = $prof->report(number => 10);

# clone the profile data set
  $clone = $prof->clone();

# get access to hash of header values
  $header = $prof->header();

# get access to sorted array of nodes
  $nodes = $prof->nodes();

# format a single node in the same style as report()
  $text = $prof->format($nodes->[0]);

# get access to Data hash in DBI::Profile format
  $Data = $prof->Data();

=head1 DESCRIPTION

This module offers the ability to read, manipulate and format
L<DBI::ProfileDumper> profile data.

Conceptually, a profile consists of a series of records, or nodes,
each of each has a set of statistics and set of keys.  Each record
must have a unique set of keys, but there is no requirement that every
record have the same number of keys.

=head1 METHODS

The following methods are supported by DBI::ProfileData objects.

=cut

our $VERSION = "2.010008";

use Carp qw(croak);
use Symbol;
use Fcntl qw(:flock);

use DBI::Profile qw(dbi_profile_merge);

# some constants for use with node data arrays
sub COUNT     () { 0 };
sub TOTAL     () { 1 };
sub FIRST     () { 2 };
sub SHORTEST  () { 3 };
sub LONGEST   () { 4 };
sub FIRST_AT  () { 5 };
sub LAST_AT   () { 6 };
sub PATH      () { 7 };

my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK})
    ? $ENV{DBI_PROFILE_FLOCK}
    : do { local $@; eval { flock STDOUT, 0; 1 } };

=head2 $prof = DBI::ProfileData->new(File => "dbi.prof")

=head2 $prof = DBI::ProfileData->new(File => "dbi.prof", Filter => sub { ... })

=head2 $prof = DBI::ProfileData->new(Files => [ "dbi.prof.1", "dbi.prof.2" ])

Creates a new DBI::ProfileData object.  Takes either a single file
through the File option or a list of Files in an array ref.  If
multiple files are specified then the header data from the first file
is used.

=head3 Files

Reference to an array of file names to read.

=head3 File

Name of file to read. Takes precedence over C<Files>.

=head3 DeleteFiles

If true, the files are deleted after being read.

Actually the files are renamed with a C<deleteme> suffix before being read,
and then, after reading all the files, they're all deleted together.

The files are locked while being read which, combined with the rename, makes it
safe to 'consume' files that are still being generated by L<DBI::ProfileDumper>.

=head3 Filter

The C<Filter> parameter can be used to supply a code reference that can
manipulate the profile data as it is being read. This is most useful for
editing SQL statements so that slightly different statements in the raw data
will be merged and aggregated in the loaded data. For example:

Filter => sub {
      my ($path_ref, $data_ref) = @_;
      s/foo = '.*?'/foo = '...'/ for @$path_ref;
  }

Here's an example that performs some normalization on the SQL. It converts all
numbers to C<N> and all quoted strings to C<S>.  It can also convert digits to
N within names. Finally, it summarizes long "IN (...)" clauses.

It's aggressive and simplistic, but it's often sufficient, and serves as an
example that you can tailor to suit your own needs:

Filter => sub {
      my ($path_ref, $data_ref) = @_;
      local $_ = $path_ref->[0]; # whichever element contains the SQL Statement
      s/\b\d+\b/N/g;             # 42 -> N
      s/\b0x[0-9A-Fa-f]+\b/N/g;  # 0xFE -> N
      s/'.*?'/'S'/g;             # single quoted strings (doesn't handle escapes)
      s/".*?"/"S"/g;             # double quoted strings (doesn't handle escapes)
      # convert names like log_20001231 into log_NNNNNNNN, controlled by $opt{n}
      s/([a-z_]+)(\d{$opt{n},})/$1.('N' x length($2))/ieg if $opt{n};
      # abbreviate massive "in (...)" statements and similar
      s!(([NS],){100,})!sprintf("$2,{repeated %d times}",length($1)/2)!eg;
  }

It's often better to perform this kinds of normalization in the DBI while the
data is being collected, to avoid too much memory being used by storing profile
data for many different SQL statement. See L<DBI::Profile>.

=cut

sub new {
    my $pkg = shift;
    my $self = {
                Files        => [ "dbi.prof" ],
		Filter       => undef,
                DeleteFiles  => 0,
                LockFile     => $HAS_FLOCK,
                _header      => {},
                _nodes       => [],
                _node_lookup => {},
                _sort        => 'none',
                @_
               };
    bless $self, $pkg;

# File (singular) overrides Files (plural)
    $self->{Files} = [ $self->{File} ] if exists $self->{File};

$self->_read_files();
    return $self;
}

# read files into _header and _nodes
sub _read_files {
    my $self = shift;
    my $files  = $self->{Files};
    my $read_header = 0;
    my @files_to_delete;

my $fh = gensym;
    foreach (@$files) {
        my $filename = $_;

if ($self->{DeleteFiles}) {
            my $newfilename = $filename . ".deleteme";
	    if ($^O eq 'VMS') {
		# VMS default filesystem can only have one period
		$newfilename = $filename . 'deleteme';
	    }
            # will clobber an existing $newfilename
            rename($filename, $newfilename)
                or croak "Can't rename($filename, $newfilename): $!";
	    # On a versioned filesystem we want old versions to be removed
	    1 while (unlink $filename);
            $filename = $newfilename;
        }

open($fh, "<", $filename)
          or croak("Unable to read profile file '$filename': $!");

# lock the file in case it's still being written to
        # (we'll be forced to wait till the write is complete)
        flock($fh, LOCK_SH) if $self->{LockFile};

if (-s $fh) {   # not empty
            $self->_read_header($fh, $filename, $read_header ? 0 : 1);
            $read_header = 1;
            $self->_read_body($fh, $filename);
        }
        close($fh); # and release lock

push @files_to_delete, $filename
            if $self->{DeleteFiles};
    }
    for (@files_to_delete){
	# for versioned file systems
	1 while (unlink $_);
	if(-e $_){
	    warn "Can't delete '$_': $!";
	}
    }

# discard node_lookup now that all files are read
    delete $self->{_node_lookup};
}

# read the header from the given $fh named $filename.  Discards the
# data unless $keep.
sub _read_header {
    my ($self, $fh, $filename, $keep) = @_;

# get profiler module id
    my $first = <$fh>;
    chomp $first;
    $self->{_profiler} = $first if $keep;

# collect variables from the header
    local $_;
    while (<$fh>) {
        chomp;
        last unless length $_;
        /^(\S+)\s*=\s*(.*)/
          or croak("Syntax error in header in $filename line $.: $_");
        # XXX should compare new with existing (from previous file)
        # and warn if they differ (different program or path)
        $self->{_header}{$1} = unescape_key($2) if $keep;
    }
}

sub unescape_key {  # inverse of escape_key() in DBI::ProfileDumper
    local $_ = shift;
    s/(?<!\\)\\n/\n/g; # expand \n, unless it's a \\n
    s/(?<!\\)\\r/\r/g; # expand \r, unless it's a \\r
    s/\\\\/\\/g;       # \\ to \
    return $_;
}

# reads the body of the profile data
sub _read_body {
    my ($self, $fh, $filename) = @_;
    my $nodes = $self->{_nodes};
    my $lookup = $self->{_node_lookup};
    my $filter = $self->{Filter};

# build up node array
    my @path = ("");
    my (@data, $path_key);
    local $_;
    while (<$fh>) {
        chomp;
        if (/^\+\s+(\d+)\s?(.*)/) {
            # it's a key
            my ($key, $index) = ($2, $1 - 1);

$#path = $index;      # truncate path to new length
            $path[$index] = unescape_key($key); # place new key at end

}
	elsif (s/^=\s+//) {
            # it's data - file in the node array with the path in index 0
	    # (the optional minus is to make it more robust against systems
	    # with unstable high-res clocks - typically due to poor NTP config
	    # of kernel SMP behaviour, i.e. min time may be -0.000008))

@data = split / /, $_;

# corrupt data?
            croak("Invalid number of fields in $filename line $.: $_")
                unless @data == 7;
            croak("Invalid leaf node characters $filename line $.: $_")
                unless m/^[-+ 0-9eE\.]+$/;

# hook to enable pre-processing of the data - such as mangling SQL
	    # so that slightly different statements get treated as the same
	    # and so merged in the results
	    $filter->(\@path, \@data) if $filter;

# elements of @path can't have NULLs in them, so this
            # forms a unique string per @path.  If there's some way I
            # can get this without arbitrarily stripping out a
            # character I'd be happy to hear it!
            $path_key = join("\0",@path);

# look for previous entry
            if (exists $lookup->{$path_key}) {
                # merge in the new data
		dbi_profile_merge($nodes->[$lookup->{$path_key}], \@data);
            } else {
                # insert a new node - nodes are arrays with data in 0-6
                # and path data after that
                push(@$nodes, [ @data, @path ]);

# record node in %seen
                $lookup->{$path_key} = $#$nodes;
            }
        }
	else {
            croak("Invalid line type syntax error in $filename line $.: $_");
	}
    }
}

=head2 $copy = $prof->clone();

Clone a profile data set creating a new object.

=cut

sub clone {
    my $self = shift;

# start with a simple copy
    my $clone = bless { %$self }, ref($self);

# deep copy nodes
    $clone->{_nodes}  = [ map { [ @$_ ] } @{$self->{_nodes}} ];

# deep copy header
    $clone->{_header} = { %{$self->{_header}} };

return $clone;
}

=head2 $header = $prof->header();

Returns a reference to a hash of header values.  These are the key
value pairs included in the header section of the L<DBI::ProfileDumper>
data format.  For example:

$header = {
    Path    => [ '!Statement', '!MethodName' ],
    Program => 't/42profile_data.t',
  };

Note that modifying this hash will modify the header data stored
inside the profile object.

=cut

sub header { shift->{_header} }

=head2 $nodes = $prof->nodes()

Returns a reference the sorted nodes array.  Each element in the array
is a single record in the data set.  The first seven elements are the
same as the elements provided by L<DBI::Profile>.  After that each key is
in a separate element.  For example:

$nodes = [
            [
              2,                      # 0, count
              0.0312958955764771,     # 1, total duration
              0.000490069389343262,   # 2, first duration
              0.000176072120666504,   # 3, shortest duration
              0.00140702724456787,    # 4, longest duration
              1023115819.83019,       # 5, time of first event
              1023115819.86576,       # 6, time of last event
              'SELECT foo FROM bar'   # 7, key1
              'execute'               # 8, key2
                                      # 6+N, keyN
            ],
                                      # ...
          ];

Note that modifying this array will modify the node data stored inside
the profile object.

=cut

sub nodes { shift->{_nodes} }

=head2 $count = $prof->count()

Returns the number of items in the profile data set.

=cut

sub count { scalar @{shift->{_nodes}} }

=head2 $prof->sort(field => "field")

=head2 $prof->sort(field => "field", reverse => 1)

Sorts data by the given field.  Available fields are:

longest
  total
  count
  shortest

The default sort is greatest to smallest, which is the opposite of the
normal Perl meaning.  This, however, matches the expected behavior of
the dbiprof frontend.

=cut

# sorts data by one of the available fields
{
    my %FIELDS = (
                  longest  => LONGEST,
                  total    => TOTAL,
                  count    => COUNT,
                  shortest => SHORTEST,
                  key1     => PATH+0,
                  key2     => PATH+1,
                  key3     => PATH+2,
                 );
    sub sort {
        my $self = shift;
        my $nodes = $self->{_nodes};
        my %opt = @_;

croak("Missing required field option.") unless $opt{field};

my $index = $FIELDS{$opt{field}};

croak("Unrecognized sort field '$opt{field}'.")
          unless defined $index;

# sort over index
        if ($opt{reverse}) {
            @$nodes = sort {
                $a->[$index] <=> $b->[$index]
            } @$nodes;
        } else {
            @$nodes = sort {
                $b->[$index] <=> $a->[$index]
            } @$nodes;
        }

# remember how we're sorted
        $self->{_sort} = $opt{field};

return $self;
    }
}

=head2 $count = $prof->exclude(key2 => "disconnect")

=head2 $count = $prof->exclude(key2 => "disconnect", case_sensitive => 1)

=head2 $count = $prof->exclude(key1 => qr/^SELECT/i)

Removes records from the data set that match the given string or
regular expression.  This method modifies the data in a permanent
fashion - use clone() first to maintain the original data after
exclude().  Returns the number of nodes left in the profile data set.

=cut

sub exclude {
    my $self = shift;
    my $nodes = $self->{_nodes};
    my %opt = @_;

# find key index number
    my ($index, $val);
    foreach (keys %opt) {
        if (/^key(\d+)$/) {
            $index   = PATH + $1 - 1;
            $val     = $opt{$_};
            last;
        }
    }
    croak("Missing required keyN option.") unless $index;

if (UNIVERSAL::isa($val,"Regexp")) {
        # regex match
        @$nodes = grep {
            $#$_ < $index or $_->[$index] !~ /$val/
        } @$nodes;
    } else {
        if ($opt{case_sensitive}) {
            @$nodes = grep {
                $#$_ < $index or $_->[$index] ne $val;
            } @$nodes;
        } else {
            $val = lc $val;
            @$nodes = grep {
                $#$_ < $index or lc($_->[$index]) ne $val;
            } @$nodes;
        }
    }

return scalar @$nodes;
}

=head2 $count = $prof->match(key2 => "disconnect")

=head2 $count = $prof->match(key2 => "disconnect", case_sensitive => 1)

=head2 $count = $prof->match(key1 => qr/^SELECT/i)

Removes records from the data set that do not match the given string
or regular expression.  This method modifies the data in a permanent
fashion - use clone() first to maintain the original data after
match().  Returns the number of nodes left in the profile data set.

=cut

sub match {
    my $self = shift;
    my $nodes = $self->{_nodes};
    my %opt = @_;

if (UNIVERSAL::isa($val,"Regexp")) {
        # regex match
        @$nodes = grep {
            $#$_ >= $index and $_->[$index] =~ /$val/
        } @$nodes;
    } else {
        if ($opt{case_sensitive}) {
            @$nodes = grep {
                $#$_ >= $index and $_->[$index] eq $val;
            } @$nodes;
        } else {
            $val = lc $val;
            @$nodes = grep {
                $#$_ >= $index and lc($_->[$index]) eq $val;
            } @$nodes;
        }
    }

return scalar @$nodes;
}

=head2 $Data = $prof->Data()

Returns the same Data hash structure as seen in L<DBI::Profile>.  This
structure is not sorted.  The nodes() structure probably makes more
sense for most analysis.

=cut

sub Data {
    my $self = shift;
    my (%Data, @data, $ptr);

foreach my $node (@{$self->{_nodes}}) {
        # traverse to key location
        $ptr = \%Data;
        foreach my $key (@{$node}[PATH .. $#$node - 1]) {
            $ptr->{$key} = {} unless exists $ptr->{$key};
            $ptr = $ptr->{$key};
        }

# slice out node data
        $ptr->{$node->[-1]} = [ @{$node}[0 .. 6] ];
    }

return \%Data;
}

=head2 $text = $prof->format($nodes->[0])

Formats a single node into a human-readable block of text.

=cut

sub format {
    my ($self, $node) = @_;
    my $format;

# setup keys
    my $keys = "";
    for (my $i = PATH; $i <= $#$node; $i++) {
        my $key = $node->[$i];

# remove leading and trailing space
        $key =~ s/^\s+//;
        $key =~ s/\s+$//;

# if key has newlines or is long take special precautions
        if (length($key) > 72 or $key =~ /\n/) {
            $keys .= "  Key " . ($i - PATH + 1) . "         :\n\n$key\n\n";
        } else {
            $keys .= "  Key " . ($i - PATH + 1) . "         : $key\n";
        }
    }

# nodes with multiple runs get the long entry format, nodes with
    # just one run get a single count.
    if ($node->[COUNT] > 1) {
        $format = <<END;
  Count         : %d
  Total Time    : %3.6f seconds
  Longest Time  : %3.6f seconds
  Shortest Time : %3.6f seconds
  Average Time  : %3.6f seconds
END
        return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST],
                       $node->[TOTAL] / $node->[COUNT]) . $keys;
    } else {
        $format = <<END;
  Count         : %d
  Time          : %3.6f seconds
END

return sprintf($format, @{$node}[COUNT,TOTAL]) . $keys;

}
}

=head2 $text = $prof->report(number => 10)

Produces a report with the given number of items.

=cut

sub report {
    my $self  = shift;
    my $nodes = $self->{_nodes};
    my %opt   = @_;

croak("Missing required number option") unless exists $opt{number};

$opt{number} = @$nodes if @$nodes < $opt{number};

my $report = $self->_report_header($opt{number});
    for (0 .. $opt{number} - 1) {
        $report .= sprintf("#" x 5  . "[ %d ]". "#" x 59 . "\n",
                           $_ + 1);
        $report .= $self->format($nodes->[$_]);
        $report .= "\n";
    }
    return $report;
}

# format the header for report()
sub _report_header {
    my ($self, $number) = @_;
    my $nodes = $self->{_nodes};
    my $node_count = @$nodes;

# find total runtime and method count
    my ($time, $count) = (0,0);
    foreach my $node (@$nodes) {
        $time  += $node->[TOTAL];
        $count += $node->[COUNT];
    }

my $header = <<END;

DBI Profile Data ($self->{_profiler})

END

# output header fields
    while (my ($key, $value) = each %{$self->{_header}}) {
        $header .= sprintf("  %-13s : %s\n", $key, $value);
    }

# output summary data fields
    $header .= sprintf(<<END, $node_count, $number, $self->{_sort}, $count, $time);
  Total Records : %d (showing %d, sorted by %s)
  Total Count   : %d
  Total Runtime : %3.6f seconds

END

return $header;
}

__END__

=head1 AUTHOR

Sam Tregar <sam@tregar.com>

=head1 COPYRIGHT AND LICENSE

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

=cut

MR SKB