view release on metacpan or  search on metacpan

bin/nytprofcalls  view on Meta::CPAN

use warnings;
use strict;

use Devel::NYTProf::Core;
require Devel::NYTProf::Data;

our $VERSION = '6.15';
    
use Data::Dumper;
use Getopt::Long;
use Carp;

GetOptions(
    'help|h'    => \&usage,
    'verbose|v' => \my $opt_verbose,
    'calls!'    => \my $opt_calls, # sum calls instead of time
    'debug|d'   => \my $opt_debug,
    'stable'    => \my $opt_stable, # used for testing (stability)
) or usage();

$opt_verbose++ if $opt_debug;
$|++ if $opt_verbose;

usage() unless @ARGV;


sub usage {
    print <<END;
usage: [perl] nytprofcalls [opts] nytprof-file [...]

 --help,        -h         Print this message
 --verbose,     -v         Be more verbose

This script is part of the Devel::NYTProf distribution.
See https://metacpan.org/release/Devel-NYTProf for details and copyright.
END
    exit 0;
}


my $last_subid = 0;
my %subname2id;

my %option;
my %attribute;


# We're building a tree structure from a stream of "subroutine returned" events.
# (We use these because the subroutine entry events don't have reliable
# value for the subroutine name, and obviously don't have timings.)
#
# Building a call tree from return events is a little tricky because they don't
# appear in natural order. The code can return from a call at any depth
# deeper than the last seen depth.
#
my $root = {};
my @stack = ($root);
my $total_in = 0;


my $callbacks = {
    OPTION    => sub { my (undef, $k, $v) = @_; $option{$k} = $v },
    ATTRIBUTE => sub { my (undef, $k, $v) = @_; $attribute{$k} = $v },
};
$callbacks->{SUB_ENTRY}  = \&on_sub_entry_log if $opt_verbose;
$callbacks->{SUB_RETURN} = \&on_sub_return_build_call_stack;
$callbacks->{all_loaded} = sub {
    output_call_path_hash( extract_call_path_hash($root) );
};


foreach my $input (@ARGV) {
    warn "Reading $input...\n" if $opt_verbose;
    Devel::NYTProf::Data->new({
        filename => $input,
        quiet => 1,
        callback => $callbacks
    });
}
$callbacks->{all_loaded}->();


exit 0;


sub on_sub_entry_log {
    my (undef, $fid, $line) = @_;
    warn "> at $fid:$line\n";
}


sub on_sub_return_build_call_stack {
    # $retn_depth is the call stack depth of the sub call we're returning from
    my (undef, $retn_depth, undef, $excl_time, $subname) = @_;

    warn sprintf "< %2d %-10s %s (stack %d)\n", $retn_depth, $subname, $excl_time, scalar @stack
        if $opt_verbose;

    my $v = ($opt_calls) ? 1 : $excl_time;
    $total_in += $v;

    # normalize and merge sibling string evals by setting eval seqn to 0
    $subname =~ s/\( (\w*eval)\s\d+ \) (?= \[ .+? :\d+ \] )/($1 0)/gx;
    # assign an id to the subname for memory efficiency
    my $subid = $subname2id{$subname} ||= ++$last_subid;

    # Either...
    # a) we're returning from some sub deeper than the current stack
    #    in which case we push unnamed sub calls ("0") onto the stack
    #    till we get to the right depth, then fall through to:
    # b) we're returning from the sub on top of the stack.

    while (@stack <= $retn_depth) { # build out the tree if needed
        my $crnt_node = $stack[-1];
        die "panic" if $crnt_node->{0};
        push @stack, ($crnt_node->{0} = {});
    }

    # top of stack:  sub we're returning from
    # next on stack: sub that was the caller
    my $sub_return = pop @stack;
    my $sub_caller = $stack[-1] || die "panic";

    die "panic" unless $sub_return == $sub_caller->{0};
    delete $sub_caller->{0} or die "panic"; # == $sub_return

    # {
    #   0 - as-yet un-returned subs
    #   'v' - cumulative excl_time in this sub
    #   $subid1 => {...} # calls to $subid1 made by this sub
    #   $subid2 => {...}
    # }

    $sub_return->{v} += $v;
    _merge_sub_return_into_caller($sub_caller->{$subid} ||= {}, $sub_return);
}


# build hash of call paths ("subid;subid;subid" => value) from the call tree
sub extract_call_path_hash {