#!/usr/bin/perl
##########################################################
# This script is part of the Devel::NYTProf distribution
#
# Copyright, contact and other information can be found
# at the bottom of this file, or by going to:
# http://search.cpan.org/dist/Devel-NYTProf/
#
##########################################################
# $Id$
##########################################################

use warnings;
use strict;

use Devel::NYTProf::Core;
require Devel::NYTProf::FileHandle;
use Devel::NYTProf::ReadStream qw(for_chunks);

our $VERSION = '2.11';
    
if ($VERSION != $Devel::NYTProf::Core::VERSION) {
    die "$0 version '$VERSION' doesn't match version '$Devel::NYTProf::Core::VERSION' of $INC{'Devel/NYTProf/Core.pm'}\n";
}

use Getopt::Long;
use Carp;

my $opt_out = 'nytprof-merged.out';

GetOptions(
    'out|o=s'   => \$opt_out,
    'help|h'    => \&usage,
    'verbose|v' => \my $opt_verbose,
) or usage();


sub usage {
    print <<END;
usage: [perl] nytprofmerge [opts] nytprof-file [...]
 --out <file>,  -o <file>  Name of output file [default: $opt_out]
 --help,        -h         Print this message
 --verbose,     -v         Be more verbose

This script of part of the Devel::NYTProf distribution.
See http://search.cpan.org/dist/Devel-NYTProf/ for details and copyright.
END
    exit 1;
}

print "Writing $opt_out\n" if $opt_verbose;
my $out = Devel::NYTProf::FileHandle::open($opt_out, "wb")
    or die "Error opening $opt_out: $!\n";

my $next_fid = 1;
my %file_to_fid;
my %fids = (0 => 0);

my $version;
my %seen_subs;

my %callers;

sub _time_block_or_line {
    my ($tag, undef, undef, $ticks, $fid, $line, $block_line, $sub_line) = @_;
    my $is_line = $tag eq 'TIME_LINE';
    $out->write($is_line ? '+' : '*');
    $out->output_int($ticks, $fid, $line);
    if (!$is_line) {
	$out->output_int($block_line);
	$out->output_int($sub_line);
    }
}

# Effectively, this is a global variable. Sorry.
my $input;

my %dispatcher =
    (
     VERSION => sub {
	 my (undef, $major, $minor) = @_;
	 my $this_version = "$major $minor";
	 if($version) {
	     die "Incompatible version '$this_version' in $input, expected '$version'"
		 unless $this_version eq $version;
	 } else {
	     $version = $this_version;
	     $out->write("NYTProf $version\n");
	 }
     },
     COMMENT => sub {
	 my (undef, $text) = @_;
	 $out->write("#$text");
     },
     ATTRIBUTE => sub {
	 my (undef, $key, $value) = @_;
	 $out->write(":$key=$value\n");
     },

     START_DEFLATE => sub {
     },

     PID_START => sub {
	 my (undef, $pid, $parent, $time) = @_;
	 $out->write('P');
	 $out->output_int($pid, $parent);
	 $out->output_nv($time);
     },
     PID_END => sub {
	 my (undef, $pid, $time) = @_;
	 $out->write('p');
	 $out->output_int($pid);
	 $out->output_nv($time);
     },

     NEW_FID => sub {
	 my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name) = @_;
	 my ($new_fid, $new_eval_fid);
	 if($eval_fid) {
	     $new_eval_fid = $fids{$eval_fid};
	     confess("unknown eval_fid $eval_fid") unless defined $new_eval_fid;
	     $new_fid = $next_fid++;
	     $fids{$fid} = $new_fid;
	 } else {
	     $new_eval_fid = $eval_fid;
	     $new_fid = $file_to_fid{$name};
	     return if defined $new_fid;

	     $new_fid = $next_fid++;
	     $fids{$fid} = $new_fid;
	     $file_to_fid{$name} = $fid;
	 }
	 $out->write('@');
	 $out->output_int($new_fid, $new_eval_fid, $eval_line, $flags, $size, $mtime);
	 $out->output_str($name);
     },
     TIME_BLOCK => \&_time_block_or_line,
     TIME_LINE => \&_time_block_or_line,

     DISCOUNT => sub {
	 $out->write('-');
     },
     SUB_INFO => sub {
	 my (undef, $fid, $first_line, $last_line, $name) = @_;
	 if(!$seen_subs{"$fid,$name"}++) {
	     $out->write('s');
	     $out->output_int($fids{$fid});
	     $out->output_str($name);
	     $out->output_int($first_line, $last_line, 0);
	 }
     },
     SUB_CALLERS => sub {
	 my (undef, $fid, $line, $count, $incl_time, $excl_time, $ucpu_time, $scpu_time, $reci_time, $rec_depth, $called, $caller) = @_;
	 $fid = $fids{$fid};

	 if ($callers{"$fid,$line"}{$called}{$caller}) {
	     my $sum = $callers{"$fid,$line"}{$called}{$caller};
	     $sum->{count} += $count;
	     $sum->{incl} += $incl_time;
	     $sum->{excl} += $excl_time;
	     $sum->{ucpu} += $ucpu_time;
	     $sum->{scpu} += $scpu_time;
	     $sum->{reci} += $reci_time;
	     $sum->{depth} = $rec_depth if $rec_depth > $sum->{depth};
	 } else {
	     # New;
	     $callers{"$fid,$line"}{$called}{$caller} =
		 {
		  depth => $rec_depth,
		  count => $count,
		  incl => $incl_time,
		  excl => $excl_time,
		  ucpu => $ucpu_time,
		  scpu => $scpu_time,
		  reci => $reci_time,
		 };
	 }
     },
     SRC_LINE => sub {
	 my (undef, $fid, $line, $text) = @_;
	 $out->write('S');
	 $out->output_int($fids{$fid}, $line);
	 $out->output_str($text);
     },
    );

foreach $input (@ARGV) {
    print "Reading $input...\n" if $opt_verbose;
    for_chunks {
	my $sub = $dispatcher{$_[0]}
            or die "Unknown tag '$_[0]' in $input\n";
	&$sub(@_);
    } filename => $input;
}

print "Finalizing...\n" if $opt_verbose;
# Deterministic order is useful for testing.
foreach my $fid_line (sort keys %callers) {
    my ($fid, $line) = split ',', $fid_line;
    foreach my $called (sort keys %{$callers{$fid_line}}) {
	foreach my $caller (sort keys %{$callers{$fid_line}{$called}}) {
	    my $sum = $callers{$fid_line}{$called}{$caller};
	    $out->write('c');
	    $out->output_int($fid, $line);
	    $out->output_str($caller);
	    $out->output_int($sum->{count});
	    $out->output_nv(@{$sum}{qw(incl excl ucpu scpu reci)});
	    $out->output_int($sum->{depth});
	    $out->output_str($called);
	}
    }
}

print "Done.\n" if $opt_verbose;
exit 0;
