/usr/lib/perl5/Devel/NYTProf/SubInfo.pm is in libdevel-nytprof-perl 5.06-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 | package Devel::NYTProf::SubInfo; # sub_subinfo
use strict;
use warnings;
use Carp;
use List::Util qw(sum min max);
use Data::Dumper;
use Devel::NYTProf::Util qw(
trace_level
);
use Devel::NYTProf::Constants qw(
NYTP_SIi_FID NYTP_SIi_FIRST_LINE NYTP_SIi_LAST_LINE
NYTP_SIi_CALL_COUNT NYTP_SIi_INCL_RTIME NYTP_SIi_EXCL_RTIME
NYTP_SIi_SUB_NAME NYTP_SIi_PROFILE
NYTP_SIi_REC_DEPTH NYTP_SIi_RECI_RTIME NYTP_SIi_CALLED_BY
NYTP_SIi_elements
NYTP_SCi_CALL_COUNT
NYTP_SCi_INCL_RTIME NYTP_SCi_EXCL_RTIME NYTP_SCi_RECI_RTIME
NYTP_SCi_REC_DEPTH NYTP_SCi_CALLING_SUB
NYTP_SCi_elements
);
# extra constants for private elements
use constant {
NYTP_SIi_meta => NYTP_SIi_elements + 1,
NYTP_SIi_cache => NYTP_SIi_elements + 2,
};
sub fid { shift->[NYTP_SIi_FID] || 0 }
sub first_line { shift->[NYTP_SIi_FIRST_LINE] }
sub last_line { shift->[NYTP_SIi_LAST_LINE] }
sub calls { shift->[NYTP_SIi_CALL_COUNT] }
sub incl_time { shift->[NYTP_SIi_INCL_RTIME] }
sub excl_time { shift->[NYTP_SIi_EXCL_RTIME] }
sub subname { shift->[NYTP_SIi_SUB_NAME] }
sub subname_without_package {
my $subname = shift->[NYTP_SIi_SUB_NAME];
$subname =~ s/.*:://;
return $subname;
}
sub profile { shift->[NYTP_SIi_PROFILE] }
sub package { (my $pkg = shift->subname) =~ s/^(.*)::.*/$1/; return $pkg }
sub recur_max_depth { shift->[NYTP_SIi_REC_DEPTH] }
sub recur_incl_time { shift->[NYTP_SIi_RECI_RTIME] }
# general purpose hash - mainly a hack to help kill off Reader.pm
sub meta { shift->[NYTP_SIi_meta()] ||= {} }
# general purpose cache
sub cache { shift->[NYTP_SIi_cache()] ||= {} }
# { fid => { line => [ count, incl_time ] } }
sub caller_fid_line_places {
my ($self, $merge_evals) = @_;
carp "caller_fid_line_places doesn't merge evals yet" if $merge_evals;
# shallow clone to remove fid 0 is_sub hack
my %tmp = %{ $self->[NYTP_SIi_CALLED_BY] || {} };
delete $tmp{0};
return \%tmp;
}
sub called_by_subnames {
my ($self) = @_;
my $callers = $self->caller_fid_line_places || {};
my %subnames;
for my $sc (map { values %$_ } values %$callers) {
my $caller_subnames = $sc->[NYTP_SCi_CALLING_SUB];
@subnames{ keys %$caller_subnames } = (); # viv keys
}
return \%subnames;
}
sub is_xsub {
my $self = shift;
# XXX should test == 0 but some xsubs still have undef first_line etc
# XXX shouldn't include opcode
my $first = $self->first_line;
return undef if not defined $first;
return 1 if $first == 0 && $self->last_line == 0;
return 0;
}
sub is_opcode {
my $self = shift;
return 0 if $self->first_line or $self->last_line;
return 1 if $self->subname =~ m/(?:^CORE::|::CORE:)\w+$/;
return 0;
}
sub is_anon {
shift->subname =~ m/::__ANON__\b/;
}
sub kind {
my $self = shift;
return 'opcode' if $self->is_opcode;
return 'xsub' if $self->is_xsub;
return 'perl';
}
sub fileinfo {
my $self = shift;
my $fid = $self->fid;
if (!$fid) {
return undef; # sub not have a known fid
}
$self->profile->fileinfo_of($fid);
}
sub clone { # shallow
my $self = shift;
return bless [ @$self ] => ref $self;
}
sub _min {
my ($a, $b) = @_;
$a = $b if not defined $a;
$b = $a if not defined $b;
# either both are defined or both are undefined here
return undef unless defined $a;
return min($a, $b);
}
sub _max {
my ($a, $b) = @_;
$a = $b if not defined $a;
$b = $a if not defined $b;
# either both are defined or both are undefined here
return undef unless defined $a;
return max($a, $b);
}
sub _alter_fileinfo {
my ($self, $remove_fi, $new_fi) = @_;
my $remove_fid = ($remove_fi) ? $remove_fi->fid : 0;
my $new_fid = ( $new_fi) ? $new_fi->fid : 0;
if ($self->fid == $remove_fid) {
$self->[NYTP_SIi_FID] = $new_fid;
$remove_fi->_remove_sub_defined($self) if $remove_fi;
$new_fi->_add_new_sub_defined($self) if $new_fi;
}
}
sub _alter_called_by_fileinfo {
my ($self, $remove_fi, $new_fi) = @_;
my $remove_fid = ($remove_fi) ? $remove_fi->fid : 0;
my $new_fid = ( $new_fi) ? $new_fi->fid : 0;
# remove mentions of $remove_fid from called-by details
# { fid => { line => [ count, incl, excl, ... ] } }
if (my $called_by = $self->[NYTP_SIi_CALLED_BY]) {
my $cb = delete $called_by->{$remove_fid};
if ($cb && $new_fid) {
my $new_cb = $called_by->{$new_fid} ||= {};
warn sprintf "_alter_called_by_fileinfo: %s from fid %d to fid %d\n",
$self->subname, $remove_fid, $new_fid
if trace_level() >= 4;
# merge $cb into $new_cb
while ( my ($line, $cb_li) = each %$cb ) {
my $dst_line_info = $new_cb->{$line} ||= [];
_merge_in_caller_info($dst_line_info, delete $cb->{$line},
tag => "$line:".$self->subname,
);
}
}
}
}
# merge details of another sub into this one
# there are very few cases where this is sane thing to do
# it's meant for merging things like anon-subs in evals
# e.g., "PPI::Node::__ANON__[(eval 286)[PPI/Node.pm:642]:4]"
sub merge_in {
my ($self, $donor, %opts) = @_;
my $self_subname = $self->subname;
my $donor_subname = $donor->subname;
warn sprintf "Merging sub %s into %s (%s)\n",
$donor_subname, $self_subname, join(" ", %opts)
if trace_level() >= 4;
# see also "case NYTP_TAG_SUB_CALLERS:" in load_profile_data_from_stream()
push @{ $self->meta->{merged_sub_names} }, $donor->subname;
$self->[NYTP_SIi_FIRST_LINE] = _min($self->[NYTP_SIi_FIRST_LINE], $donor->[NYTP_SIi_FIRST_LINE]);
$self->[NYTP_SIi_LAST_LINE] = _max($self->[NYTP_SIi_LAST_LINE], $donor->[NYTP_SIi_LAST_LINE]);
$self->[NYTP_SIi_CALL_COUNT] += $donor->[NYTP_SIi_CALL_COUNT];
$self->[NYTP_SIi_INCL_RTIME] += $donor->[NYTP_SIi_INCL_RTIME];
$self->[NYTP_SIi_EXCL_RTIME] += $donor->[NYTP_SIi_EXCL_RTIME];
$self->[NYTP_SIi_REC_DEPTH] = max($self->[NYTP_SIi_REC_DEPTH], $donor->[NYTP_SIi_REC_DEPTH]);
# adding reci_rtime is correct only if one sub doesn't call the other
$self->[NYTP_SIi_RECI_RTIME] += $donor->[NYTP_SIi_RECI_RTIME]; # XXX
# { fid => { line => [ count, incl_time, ... ] } }
my $dst_called_by = $self ->[NYTP_SIi_CALLED_BY] ||= {};
my $src_called_by = $donor->[NYTP_SIi_CALLED_BY] || {};
$opts{opts} ||= "merge in $donor_subname";
# iterate over src and merge into dst
while (my ($fid, $src_line_hash) = each %$src_called_by) {
my $dst_line_hash = $dst_called_by->{$fid};
# merge lines in %$src_line_hash into %$dst_line_hash
for my $line (keys %$src_line_hash) {
my $dst_line_info = $dst_line_hash->{$line} ||= [];
my $src_line_info = $src_line_hash->{$line};
delete $src_line_hash->{$line} unless $opts{src_keep};
_merge_in_caller_info($dst_line_info, $src_line_info, %opts);
}
}
return;
}
sub _merge_in_caller_info {
my ($dst_line_info, $src_line_info, %opts) = @_;
my $tag = ($opts{tag}) ? " $opts{tag}" : "";
if (!@$src_line_info) {
carp sprintf "_merge_in_caller_info%s skipped (empty donor)", $tag
if trace_level();
return;
}
if (trace_level() >= 5) {
carp sprintf "_merge_in_caller_info%s merging from $src_line_info -> $dst_line_info:", $tag;
warn sprintf " . %s\n", _fmt_sc($src_line_info);
warn sprintf " + %s\n", _fmt_sc($dst_line_info);
}
if (!@$dst_line_info) {
@$dst_line_info = (0) x NYTP_SCi_elements;
$dst_line_info->[NYTP_SCi_CALLING_SUB] = undef;
}
# merge @$src_line_info into @$dst_line_info
$dst_line_info->[$_] += $src_line_info->[$_] for (
NYTP_SCi_CALL_COUNT, NYTP_SCi_INCL_RTIME, NYTP_SCi_EXCL_RTIME,
);
$dst_line_info->[NYTP_SCi_REC_DEPTH] = max($dst_line_info->[NYTP_SCi_REC_DEPTH],
$src_line_info->[NYTP_SCi_REC_DEPTH]);
# ug, we can't really combine recursive incl_time, but this is better than undef
$dst_line_info->[NYTP_SCi_RECI_RTIME] = max($dst_line_info->[NYTP_SCi_RECI_RTIME],
$src_line_info->[NYTP_SCi_RECI_RTIME]);
my $src_cs = $src_line_info->[NYTP_SCi_CALLING_SUB]|| {};
my $dst_cs = $dst_line_info->[NYTP_SCi_CALLING_SUB]||={};
$dst_cs->{$_} = $src_cs->{$_} for keys %$src_cs;
warn sprintf " = %s\n", _fmt_sc($dst_line_info)
if trace_level() >= 5;
return;
}
sub _fmt_sc {
my ($sc) = @_;
return "(empty)" if !@$sc;
my $dst_cs = $sc->[NYTP_SCi_CALLING_SUB]||{};
my $by = join " & ", sort keys %$dst_cs;
sprintf "calls %d%s",
$sc->[NYTP_SCi_CALL_COUNT], ($by) ? ", by $by" : "";
}
sub caller_fids {
my ($self, $merge_evals) = @_;
my $callers = $self->caller_fid_line_places($merge_evals) || {};
my @fids = keys %$callers;
return @fids; # count in scalar context
}
sub caller_count { return scalar shift->caller_places; } # XXX deprecate later
# array of [ $fid, $line, $sub_call_info ], ...
sub caller_places {
my ($self, $merge_evals) = @_;
my $callers = $self->caller_fid_line_places || {};
my @callers;
for my $fid (sort { $a <=> $b } keys %$callers) {
my $lines_hash = $callers->{$fid};
for my $line (sort { $a <=> $b } keys %$lines_hash) {
push @callers, [ $fid, $line, $lines_hash->{$line} ];
}
}
return @callers; # scalar: number of distinct calling locations
}
sub normalize_for_test {
my $self = shift;
my $profile = $self->profile;
# normalize eval sequence numbers in anon sub names to 0
$self->[NYTP_SIi_SUB_NAME] =~ s/ \( ((?:re_)?) eval \s \d+ \) /(${1}eval 0)/xg
if $self->[NYTP_SIi_SUB_NAME] =~ m/__ANON__/
&& not $ENV{NYTPROF_TEST_SKIP_EVAL_NORM};
# zero subroutine inclusive time
$self->[NYTP_SIi_INCL_RTIME] = 0;
$self->[NYTP_SIi_EXCL_RTIME] = 0;
$self->[NYTP_SIi_RECI_RTIME] = 0;
# { fid => { line => [ count, incl, excl, ... ] } }
my $callers = $self->[NYTP_SIi_CALLED_BY] || {};
# calls from modules shipped with perl cause problems for tests
# because the line numbers vary between perl versions, so here we
# edit the line number of calls from these modules
for my $fid (keys %$callers) {
next if not $fid;
my $fileinfo = $profile->fileinfo_of($fid) or next;
next if $fileinfo->filename !~ /(AutoLoader|Exporter)\.pm$/;
# normalize the lines X,Y,Z to 1,2,3
my %lines = %{ delete $callers->{$fid} };
my @lines = @lines{sort { $a <=> $b } keys %lines};
$callers->{$fid} = { map { $_ => shift @lines } 1..@lines };
}
for my $sc (map { values %$_ } values %$callers) {
# zero per-call-location subroutine inclusive time
$sc->[NYTP_SCi_INCL_RTIME] =
$sc->[NYTP_SCi_EXCL_RTIME] =
$sc->[NYTP_SCi_RECI_RTIME] = 0;
if (not $ENV{NYTPROF_TEST_SKIP_EVAL_NORM}) {
# normalize eval sequence numbers in anon sub names to 0
my $names = $sc->[NYTP_SCi_CALLING_SUB]||{};
for my $subname (keys %$names) {
(my $newname = $subname) =~ s/ \( ((?:re_)?) eval \s \d+ \) /(${1}eval 0)/xg;
next if $newname eq $subname;
warn "Normalizing $subname to $newname overwrote other calling-sub data\n"
if $names->{$newname};
$names->{$newname} = delete $names->{$subname};
}
}
}
return $self->[NYTP_SIi_SUB_NAME];
}
sub dump {
my ($self, $separator, $fh, $path, $prefix) = @_;
my ($fid, $l1, $l2, $calls) = @{$self}[
NYTP_SIi_FID, NYTP_SIi_FIRST_LINE, NYTP_SIi_LAST_LINE, NYTP_SIi_CALL_COUNT
];
my @values = @{$self}[
NYTP_SIi_INCL_RTIME, NYTP_SIi_EXCL_RTIME,
NYTP_SIi_REC_DEPTH, NYTP_SIi_RECI_RTIME
];
printf $fh "%s[ %s:%s-%s calls %s times %s ]\n",
$prefix,
map({ defined($_) ? $_ : 'undef' } $fid, $l1, $l2, $calls),
join(" ", map { defined($_) ? $_ : 'undef' } @values);
my @caller_places = $self->caller_places;
for my $cp (@caller_places) {
my ($fid, $line, $sc) = @$cp;
my @sc = @$sc;
$sc[NYTP_SCi_CALLING_SUB] = join "|", sort keys %{ $sc[NYTP_SCi_CALLING_SUB] };
printf $fh "%s%s%s%d:%d%s[ %s ]\n",
$prefix,
'called_by', $separator,
$fid, $line, $separator,
join(" ", map { defined($_) ? $_ : 'undef' } @sc);
}
# where a sub has had others merged into it, list them
my $merge_subs = $self->meta->{merged_sub_names} || [];
for my $ms (sort @$merge_subs) {
printf $fh "%s%s%s%s\n",
$prefix, 'merge_donor', $separator, $ms;
}
}
# vim:ts=8:sw=4:et
1;
|