Revision: 1046
Author: [email protected]
Date: Mon Feb 8 06:49:38 2010
Log: When merging, enforce identical profile file attributes where
appropriate.
Write out the minimum seen value for 'basetime', and
concatenate 'application'.
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1046
Modified:
/trunk/bin/nytprofmerge
=======================================
--- /trunk/bin/nytprofmerge Fri Jan 22 02:56:08 2010
+++ /trunk/bin/nytprofmerge Mon Feb 8 06:49:38 2010
@@ -16,6 +16,7 @@
use Devel::NYTProf::Core;
require Devel::NYTProf::FileHandle;
use Devel::NYTProf::ReadStream qw(for_chunks);
+use List::Util qw(min);
our $VERSION = '3.01';
@@ -76,8 +77,14 @@
}
}
-# Effectively, this is a global variable. Sorry.
+# Croak if any of these attributes differ between profiles
+my %identical = map {$_, 1}
+ qw (ARCHLIB_EXP PL_perldb PRIVLIB_EXP clock_id nv_size perl_version
+ ticks_per_sec xs_version);
+
+# Effectively, these are global variables. Sorry.
my $input;
+my %attributes;
my %dispatcher =
(
@@ -98,7 +105,18 @@
},
ATTRIBUTE => sub {
my (undef, $key, $value) = @_;
- $out->write(":$key=$value\n");
+ if ($identical{$key}) {
+ if (exists $attributes{$key}) {
+ if ($attributes{$key} ne $value) {
+ die ("In $input, attribute '$key' has value '$value', which differs
from the previous value for that key, '$attributes{$key}'\n");
+ }
+ } else {
+ $attributes{$key} = $value;
+ $out->write(":$key=$value\n");
+ }
+ } else {
+ push @{$attributes{$key}}, $value;
+ }
},
START_DEFLATE => sub {
@@ -296,6 +314,21 @@
}
}
}
+
+foreach my $key (sort grep {!$identical{$_}} keys %attributes) {
+ my @values = @{$attributes{$key}};
+ if ($key eq 'basetime') {
+ my $value = min(@values);
+ $out->write(":$key=$value\n");
+ } elsif ($key eq 'application') {
+ my $last = pop @values;
+ my $value = @values ? join (', ', @values) . "and $last" : $last;
+ $out->write(":$key=$value\n");
+ } else {
+ warn "Unknown attribute $key\n";
+ $out->write(":$key=$_\n") foreach @values;
+ }
+}
print "Done.\n" if $opt_verbose;
exit 0;
--
You've received this message because you are subscribed to
the Devel::NYTProf Development User group.
Group hosted at: http://groups.google.com/group/develnytprof-dev
Project hosted at: http://perl-devel-nytprof.googlecode.com
CPAN distribution: http://search.cpan.org/dist/Devel-NYTProf
To post, email: [email protected]
To unsubscribe, email: [email protected]
