#!/usr/bin/perl
##########################################################
## This script is part of the Devel::NYTProf distribution
## Released under the same terms as Perl 5.8.0
## See http://metacpan.org/release/Devel-NYTProf/
##
##########################################################
use warnings;
use strict;

use Getopt::Long;

use Devel::NYTProf::Data;


my %opt = (
    file => 'nytprof.out',
    out  => 'nytprof.callgrind',
);

GetOptions( \%opt, qw/file|f=s out|o=s help|h/ )
    or usage();

usage() if $opt{help};


print "Reading $opt{file} ...\n";

my $profile = Devel::NYTProf::Data->new( { filename => $opt{file},
                                           quiet => 1 } );

print "Writing $opt{out} ...\n";

# calltree format specification
# http://kcachegrind.sourceforge.net/cgi-bin/show.cgi/KcacheGrindCalltreeFormat

open my $fh, '>', $opt{out}
    or die "Can't write to $opt{out}: $!\n";

print $fh "events: Ticks".$/;
print $fh $/;


my %callmap;
my $subname_subinfo_map = $profile->subname_subinfo_map;

for my $sub (values %$subname_subinfo_map) {

    my $callers = $sub->caller_fid_line_places;
    next unless ($callers && %$callers);

    my $fi = eval { $sub->fileinfo };

    print $fh 'fl='.( $fi ? $fi->filename : "Unknown").$/;
    print $fh 'fn='.$sub->subname.$/;
    print $fh join(' ',$sub->first_line, int($sub->excl_time * 1_000_000)).$/;
    print $fh $/;

    my @callers;
    while ( my ( $fid, $fid_line_info ) = each %$callers ) {
        for my $line ( keys %$fid_line_info ) {
            my ( $count, $incl_time, $excl_time, undef, undef, undef,
                undef, $calling_subs) = @{ $fid_line_info->{$line} };

            my @subnames = sort keys %$calling_subs;

            ref $_ and $_ = sprintf "%s (merge of %d subs)", $_->[0], scalar @$_
                for @subnames;
            my $subname = (@subnames) ? join( " or ", @subnames ) : "__main";

            my $fi        = $profile->fileinfo_of($fid);
            my $filename  = $fi->filename($fid);
            my $line_desc = "line $line of $filename";

            # chase string eval chain back to a real file
            while ( my ( $outer_fileinfo, $outer_line ) = $fi->outer ) {
                ( $filename, $line ) = ( $outer_fileinfo->filename, $outer_line );
                $line_desc .= sprintf " at line %s of %s", $line, $filename;
                $fi = $outer_fileinfo;
            }

            push @{ $callmap{$subname} }, [ $filename, $line, $sub, $count, $incl_time, $excl_time ];
        }
    }

}

for (keys %callmap) {
    for my $entry (@{$callmap{$_}}) {
        my ($filename, $line, $sub, $count, $incl_time, $excl_time) = @$entry;
        print $fh "fl=$filename$/";
        print $fh 'fn='.$_.$/;
        print $fh "cfl=".(eval { $sub->fileinfo->filename } || 'Unknown').$/;
        print $fh "cfn=".$sub->subname.$/;
        # calls=(Call Count) (Destination position)
        # (Source position) (Inclusive cost of call)
        print $fh "calls=$count ".$sub->first_line.$/;
        print $fh "$line ".int(1_000_000 * $incl_time).$/;
        print $fh $/;
    }
}

sub usage {
    print <<END;
usage: [perl] nytprofcg [opts]
 --file <file>, -f <file>  Specify NYTProf data file [default: nytprof.out]
 --out <file>,  -o <file>  Specify output file [default: nytprof.callgrind]
 --help,        -h         Print this message

This script of part of the Devel::NYTProf distribution.
Released under the same terms as Perl 5.8.0
See http://metacpan.org/release/Devel-NYTProf/
END
    exit 1;
}

__END__

=head1 NAME

nytprofcg - Convert an NYTProf profile into Callgrind format

=head1 SYNOPSIS

 $ nytprofcg --file=nytprof.out --out=nytprof.callgrind

 $ nytprofcg    # same as above

=head1 DESCRIPTION

Reads a profile data file generated by Devel::NYTProf and writes out the
subroutine call graph information it contains in Callgrind format.

The output Callgrind file can be loaded into the C<kcachegrind> GUI for
interactive exploration. 

For more information see L<http://kcachegrind.github.io/html/Home.html>

=cut