Devel::DProfPP - Parse C<Devel::DProf> output

  use Devel::DProfPP;
  my $pp = Devel::DProfPP->new;

  Devel::DProfPP->new(
        file    => "../tmon.out",
        enter   => sub { my ($self, $sub_name)  = shift;
                         my $frame = ($self->stack)[-1];
                         print "\t" x $frame->height, $frame->sub_name;
                       }
  )->parse;

    new(
        file    => $file,
        enter   => \&entersub_code,
        leave   => \&leavesub_code
    );

package Devel::DProfPP;
use 5.006;
use strict;
use warnings;
use Carp;
our $VERSION = '1.3';
use constant DUMMY => sub {};
my $magic = "fOrTyTwO";

sub new {
    my $class = shift;
    my %args = @_;
    open my $fh, ($args{file} ||= "tmon.out") 
        or croak "Can't open $args{file}: $!";
    bless {
        fh    => $fh,
        enter => ($args{enter} || DUMMY),
        leave => ($args{leave} || DUMMY),
        stack => [],
        syms  => {},
        cum_times => {}
    }, $class;
}

sub parse {
    my $self = shift;
    $self->_parse_header;
    $self->_parse_body;
}

sub _parse_header {
    my $self = shift;
    my ($hz, $XS_VERSION, $over_utime, $over_stime, $over_rtime);
    my ($over_tests, $rrun_utime, $rrun_stime, $rrun_rtime, $total_marks);
    my $fh = $self->{fh};
    my $head = <$fh>;
    if(!defined $head || $head !~ /$magic/) {
        croak "This isn't really DProf output";
    }

    while (<$fh>) {
        last if /^PART2/;
        eval;
    }
    no strict 'refs';
    $self->{header} = {
        hz => $hz,
        XS_VERSION => $XS_VERSION,
        over_utime => $over_utime, over_stime => $over_stime,
        over_rtime => $over_rtime,
        over_tests => $over_tests,
        rrun_utime => $rrun_utime, rrun_stime => $rrun_stime,
        rrun_rtime => $rrun_rtime,
        total_marks => $total_marks,
    };
}

sub _parse_body {
    my $self = shift;
    my $fh = $self->{fh};

    while (<$fh>) {
        chomp;
        /^\@ ([\da-f]+) (\d+) (\d+)/ && do { $self->_add_times($1,$2,$3);     next;};
        /^\& ([\da-f]+) (\S+) (\S+)/ && do { $self->_introduce_sub($1,$2,$3); next;};
        /^\+ ([\da-f]+)/             && do { $self->_enter($1);               next;};
        /^\- ([\da-f]+)/             && do { $self->_leave($1);               next;};
        /^\+ & (\S+)/           && do { $self->_enter_named($1);         next;};
        /^\- & (\S+)/           && do { $self->_leave_named($1);         next;};
        /^\* ([\da-f]+)/             && do { $self->_goto($1);                next;};
        /^\/ ([\da-f]+)/             && do { $self->_die($1);                 next;};
        die "Didn't expect to see <$_> at this stage of play";
    }
}

sub _add_times {
    my ($self, @times) = @_;
    if (@{$self->{stack}} == 0) {
        # There's an interesting buglet in Devel::DProf/dprofpp that it
        # doesn't actually cater for timing the entire program. So
        # neither do we.
        return
    }
    $self->{stack}[-1]{times}[$_] += $times[$_] for 0..2;
    $self->{cum_times}{$self->{stack}[-1]{sub_name}}[$_] += $times[$_] for 0..2;
    for my $frame (@{$self->{stack}}) {
        $frame->{inc_times}[$_] += $times[$_] for 0..2;
    }
}

sub _introduce_sub {
    my ($self, $num, $pack, $sym) = @_;
    $self->{syms}{$num} = $pack."::".$sym;
}

sub stack { @{$_[0]->{stack}} }

sub header { $_[0]->{header} }

sub _enter { 
    my ($self, $num) = @_;
    my $name = $self->{syms}{$num};
    die "Entering unknown subroutine $num" unless $name;
    $self->_enter_named($name);
}
sub _leave {
    my ($self, $num) = @_;
    my $name = $self->{syms}{$num};
    die "Leaving unknown subroutine $num" unless $name;
    $self->_leave_named($name);
}

sub _goto { 
    my ($self, $num) = @_;
    pop @{$self->{stack}};
    $self->_enter($num);
}
sub _die { goto &_leave }

sub _enter_named {
    my ($self, $sub) = @_;
    my $frame = Devel::DProfPP::Frame->new(
        parent => $self,
        sub_name => $sub,
        times => [0,0,0],
        inc_times => [0,0,0],
        height => ($#{$self->{stack}} + 1)
    );
    push @{$self->{stack}}, $frame;
    $self->{enter}->($self, $sub);
}

sub _leave_named {
    my ($self, $sub) = @_;
    $self->{leave}->($self, $sub);
    pop @{$self->{stack}};
}

1;

package Devel::DProfPP::Frame;

sub new       { 
    my $class = shift;
    bless {@_}, $class;
}

sub times     { map { $_/($_[0]->{parent}{header}{hz})} @{$_[0]->{times}} }
sub inc_times { map { $_/($_[0]->{parent}{header}{hz})} @{$_[0]->{inc_times}} }
sub cum_times {
    my $self = shift;
    map { $_/($self->{parent}{header}{hz}) } 
    @{$self->{parent}{cum_times}{$self->{sub_name}} ||= [0,0,0]};
}
sub height     { $_[0]->{height} }
sub sub_name  { $_[0]->{sub_name} }

1;