view release on metacpan or  search on metacpan

lib/Devel/NYTProf/Data.pm  view on Meta::CPAN

=head1 METHODS

=cut


use warnings;
use strict;

use Carp qw(carp croak cluck);
use Cwd qw(getcwd);
use Scalar::Util qw(blessed);

use Devel::NYTProf::Core;
use Devel::NYTProf::FileInfo;
use Devel::NYTProf::SubInfo;
use Devel::NYTProf::Util qw( trace_level _dumper );

our $VERSION = '6.15';


=head2 new

  $profile = Devel::NYTProf::Data->new( );

  $profile = Devel::NYTProf::Data->new( {
    filename => 'nytprof.out', # default
    quiet    => 0,             # default, 1 to silence message
  } );

Reads the specified file containing profile data written by L<Devel::NYTProf>,
aggregates the contents, and returns the results as a blessed data structure.

=cut


sub new {
    my $class = shift;
    my $args = shift || { };

    my $file = $args->{filename} ||= 'nytprof.out';
    croak "Devel::NYTProf::new() could not locate file for processing"
        unless -f $file;

    print "Reading $file\n" unless $args->{quiet};

    my $profile = load_profile_data_from_file(
        $file,
        $args->{callback},
    );

    return undef if $args->{callback};

    print "Processing $file data\n" unless $args->{quiet};

    bless $profile => $class;

    my $fid_fileinfo = $profile->{fid_fileinfo};
    my $sub_subinfo  = $profile->{sub_subinfo};

    # add profile ref so fidinfo & subinfo objects
    # XXX circular ref, add weaken
    for (@$fid_fileinfo) { $_ and $_->[7] = $profile; }
    $_->[7] = $profile for values %$sub_subinfo;

    # bless sub_subinfo data
    (my $sub_class = $class) =~ s/\w+$/SubInfo/;
    $_ and bless $_ => $sub_class for values %$sub_subinfo;

    # create profiler_active attribute by subtracting from profiler_duration
    # currently we only subtract cumulative_overhead_ticks
    my $attribute = $profile->{attribute};
    my $overhead_time = $attribute->{cumulative_overhead_ticks} / $attribute->{ticks_per_sec};
    $attribute->{profiler_active} = $attribute->{profiler_duration} - $overhead_time;

    # find subs that have calls but no fid
    my @homeless_subs = grep { $_->calls and not $_->fid } values %$sub_subinfo;
    if (@homeless_subs) { # give them a home...
        # currently just the first existing fileinfo
        # XXX ought to create a new dummy fileinfo for them
        my $new_fi = $profile->fileinfo_of(1);
        $_->_alter_fileinfo(undef, $new_fi) for @homeless_subs;
    }


    # Where a given eval() has been invoked more than once
    # rollup the corresponding fids if they're "uninteresting".
    if (not $args->{skip_collapse_evals}) {
        for my $fi ($profile->noneval_fileinfos) {
            $profile->collapse_evals_in($fi);
        }
    }

    $profile->_clear_caches;

    # a hack for testing/debugging
    # $ENV{NYTPROF_ONLOAD} must be a colon-delimited string of
    # equal-sign-delimited substrings, e.g.,
    # 'alpha=beta:gamma=delta:dump=1:exit=1';

    if (my $env = $ENV{NYTPROF_ONLOAD}) {
        my %onload = map { split /=/, $_, 2 } split /:/, $env, -1;
        warn _dumper($profile) if $onload{dump};
        exit $onload{exit}     if defined $onload{exit};
    }

    return $profile;
}


sub collapse_evals_in {
    my ($profile, $parent_fi) = @_;
    my $parent_fid = $parent_fi->fid;

    my %evals_on_line;
    for my $fi ($parent_fi->has_evals) {
        $profile->collapse_evals_in($fi); # recurse first
        push @{ $evals_on_line{$fi->eval_line} }, $fi;
    }

    while ( my ($line, $siblings) = each %evals_on_line) {