#!/usr/bin/perl
##########################################################
## This script is part of the Devel::NYTProf distribution
## Released under the same terms as Perl 5.8.0
## See http://search.cpan.org/dist/Devel-NYTProf/
##
##########################################################
# $Id: /mirror/devel-nytprof/bin/nytprofhtml 13295 2009-04-06T20:34:49.946854Z tim.bunce  $
###########################################################
use warnings;
use strict;
use Devel::NYTProf::Data;
use Getopt::Long;

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

process_cli();

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 * 1000000)).$/;
    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(1000000 * $incl_time).$/;
        print $fh $/;
    }
}

sub process_cli {
    GetOptions( \%opt, qw/file|f=s out|o=s help|h/ )
        or do {
            usage();
            exit 1;
        };

    if ( defined( $opt{help} ) ) {
        usage();
        exit;
    }
}

sub usage {
    print <<END
usage: [perl] nytprofcg [opts]
 --file <file>, -f <file>  Use the specified file as Devel::NYTProf database
                            file. [default: ./nytprof.out]
 --out <dir>,   -o <dir>   Place generated files here [default: ./nytprof]
 --delete,      -d         Delete the old output [uses --out]
 --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://search.cpan.org/dist/Devel-NYTProf/
END
}

__END__
