This file is indexed.

/usr/lib/perl5/Devel/NYTProf/Reader.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
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
# vim: ts=8 sw=4 expandtab:
##########################################################
## 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/
##
###########################################################
package Devel::NYTProf::Reader;

our $VERSION = '4.06';

use warnings;
use strict;
use Carp;
use Config;

use List::Util qw(sum max);
use Data::Dumper;

use Devel::NYTProf::Data;
use Devel::NYTProf::Util qw(
    fmt_float
    fmt_time
    html_safe_filename
    calculate_median_absolute_deviation
    trace_level
);

# These control the limits for what the script will consider ok to severe times
# specified in standard deviations from the mean time
use constant SEVERITY_SEVERE => 2.0;    # above this deviation, a bottleneck
use constant SEVERITY_BAD    => 1.0;
use constant SEVERITY_GOOD   => 0.5;    # within this deviation, okay


# Static class variables
our $FLOAT_FORMAT = $Config{nvfformat};
$FLOAT_FORMAT =~ s/"//g;

# Class methods
sub new {
    my $class = shift;
    my $file  = shift;
    my $opts  = shift || {};

    my $self = {
        file => $file || 'nytprof.out',
        output_dir => '.',
        suffix     => '.csv',
        header     => "# Profile data generated by Devel::NYTProf::Reader\n"
            . "# Version: v$Devel::NYTProf::Core::VERSION\n"
            . "# More information at http://search.cpan.org/dist/Devel-NYTProf/\n"
            . "# Format: time,calls,time/call,code\n",
        datastart => '',
        mk_report_source_line => undef,
        mk_report_xsub_line   => undef,
        mk_report_separator_line => undef,
        line      => [
            {},
            {value => 'time',      end => ',', default => '0'},
            {value => 'calls',     end => ',', default => '0'},
            {value => 'time/call', end => ',', default => '0'},
            {value => 'source',    end => '',  default => ''},
            {end   => "\n"}
        ],
        dataend  => '',
        footer   => '',
        merged_fids => '',
        taintmsg => "# WARNING!\n"
            . "# The source file used in generating this report has been modified\n"
            . "# since generating the profiler database.  It might be out of sync\n",
        sawampersand => "# NOTE!\n"
            . "# This file uses special regexp match variables that impact the performance\n"
            . "# of all regular expression in the program!\n"
            . "# See WARNING in http://perldoc.perl.org/perlre.html#Capture-buffers\n",
    };

    bless($self, $class);
    $self->{profile} = Devel::NYTProf::Data->new({
        %$opts,
        filename => $self->{file},
    });

    return $self;
}



##
sub set_param {
    my ($self, $param, $value) = @_;

    if (!exists $self->{$param}) {
        confess "Attempt to set $param to $value failed: $param is not a valid " . "parameter\n";
    }
    else {
        return $self->{$param} unless defined($value);
        $self->{$param} = $value;
    }
    undef;
}


sub get_param {
    my ($self, $param, $code_args) = @_;
    my $value = $self->{$param};
    if (ref $value eq 'CODE') {
        $code_args ||= [];
        $value = $value->(@$code_args);
    }
    return $value;
}

##
sub file_has_been_modified {
    my $self = shift;
    my $file = shift;
    return undef unless -f $file;
    my $mtime = (stat $file)[9];
    return ($mtime > $self->{profile}{attribute}{basetime});
}

##
sub _output_additional {
    my ($self, $fname, $content) = @_;
    open(OUT, '>', "$self->{output_dir}/$fname")
        or confess "Unable to open $self->{output_dir}/$fname for writing; $!\n";
    print OUT $content;
    close OUT;
}

##
sub output_dir {
    my ($self, $dir) = @_;
    return $self->{output_dir} unless defined($dir);
    if (!mkdir $dir) {
        confess "Unable to create directory $dir: $!\n" if !$! =~ /exists/;
    }
    $self->{output_dir} = $dir;
}

##
sub report {
    my $self = shift;
    my ($opts) = @_;

    my $level_additional_sub = $opts->{level_additional};
    my $profile              = $self->{profile};
    my $modes                = $profile->get_profile_levels;
    my @levels = grep { {reverse %$modes}->{$_} } qw(sub block line);
    for my $level (@levels) {
        print "Writing $level reports to $self->{output_dir} directory\n"
            unless $opts->{quiet};
        $self->_generate_report($profile, $level,
            show_progress => (not $opts->{quiet} and -t STDOUT)
        );
        $level_additional_sub->($profile, $level)
            if $level_additional_sub;
    }
}

sub current_level {
    my $self = shift;
    $self->{current_level} = shift if @_;
    return $self->{current_level} || 'line';
}

sub fname_for_fileinfo {
    my ($self, $fi, $level) = @_;
    confess "No fileinfo" unless $fi;
    $level ||= $self->current_level;

    my $fname = $fi->filename_without_inc;

    # We want to have descriptive and unambiguous filename
    # but we don't want to risk failure due to filenames being longer
    # than MAXPATH (including the length of whatever dir we're writing
    # the report files into). So we truncate to the last component if
    # the filenames seems 'dangerously long'. XXX be smarter about this.
    # This is safe from ambiguity because we add the fid to the filename below.
    my $max_len = $ENV{NYTPROF_FNAME_TRIM} || 50;
    $fname =~ s!/.*/!/.../! if length($fname) > $max_len; # remove dir path
    $fname = "TOOLONG"      if length($fname) > $max_len; # just in case

    $fname = html_safe_filename($fname);
    $fname .= "-".$fi->fid; # to ensure uniqueness and for info
    $fname .= "-$level" if $level;

    return $fname;
}


##
sub _generate_report {
    my $self = shift;
    my ($profile, $LEVEL, %opts) = @_;

    $self->current_level($LEVEL);

    my @all_fileinfos = $profile->all_fileinfos
        or carp "Profile report data contains no files";

    #$profile->dump_profile_data({ filehandle => \*STDERR, separator=>"\t", });

    my @fis = @all_fileinfos;
    if ($LEVEL ne 'line') {
        # we only generate line-level reports for evals
        # for efficiency and because some data model editing only
        # is only implemented for line-level data
        @fis = grep { not $_->is_eval } @fis;
    }

    my $progress;
    foreach my $fi (@fis) {

        if ($opts{show_progress}) {
            local $| = 1;
            ++$progress;
            printf "\r %3d%% ... ", $progress/@fis*100;
        }

        my $meta = $fi->meta;
        my $filestr = $fi->filename;

        # { linenumber => { subname => [ count, time ] } }
        my $subcalls_at_line = { %{ $fi->sub_call_lines } };
        my $subcalls_max_line = max( keys %$subcalls_at_line ) || 0;

        # { linenumber => [ $subinfo, ... ] }
        my $subdefs_at_line = { %{ $profile->subs_defined_in_file_by_line($filestr) } };
        my $subdefs_max_line = max( keys %$subdefs_at_line ) || 0;
        delete $subdefs_at_line->{0}; # xsubs handled separately

        # { linenumber => { fid => $fileinfo } }
        my $evals_at_line = { %{ $fi->evals_by_line } };
        my $evals_max_line = max( keys %$evals_at_line ) || 0;

        # note that a file may have no source lines executed, so no keys here
        # (but is included because some xsubs in the package were executed)
        my $lines_array = $fi->line_time_data([$LEVEL]) || [];
        my $src_max_line = scalar @$lines_array;

        for ($src_max_line, $subcalls_max_line, $subdefs_max_line, $evals_max_line) {
            next if $_ < 2**16;
            warn "Ignoring indication that $filestr has $_ lines! (Possibly corrupt data)\n";
            $_ = 0;
        }

        my $max_linenum = max(
            $src_max_line,
            $subcalls_max_line,
            $subdefs_max_line,
            $evals_max_line,
        );

        warn sprintf "%s max lines: %s (stmts %s, subcalls %s, subdefs %s, evals %s)\n",
                $filestr, $max_linenum, scalar @$lines_array,
                $subcalls_max_line, $subdefs_max_line, $evals_max_line
            if trace_level() >= 4 or $max_linenum > 2**15;

        my %stats_accum;           # holds all line times. used to find median
        my %stats_by_line;         # holds individual line stats
        my $runningTotalTime = 0;  # holds the running total
        # (should equal sum of $stats_accum)
        my $runningTotalCalls = 0; # holds the running total number of calls.

        for (my $linenum = 0; $linenum <= $max_linenum; ++$linenum) {

            if (my $subdefs = delete $subdefs_at_line->{$linenum}) {
                $stats_by_line{$linenum}->{'subdef_info'}  = $subdefs;
            }

            if (my $subcalls = delete $subcalls_at_line->{$linenum}) {
                my $line_stats = $stats_by_line{$linenum} ||= {};

                $line_stats->{'subcall_info'}  = $subcalls;
                $line_stats->{'subcall_count'} = sum(map { $_->[0] } values %$subcalls);
                $line_stats->{'subcall_time'}  = sum(map { $_->[1] } values %$subcalls);

                push @{$stats_accum{$_}}, $line_stats->{$_}
                    for (qw(subcall_count subcall_time));
            }

            if (my $evalcalls = delete $evals_at_line->{$linenum}) {
                my $line_stats = $stats_by_line{$linenum} ||= {};

                # %$evals => { fid => $fileinfo }
                $line_stats->{'evalcall_info'}  = $evalcalls;
                $line_stats->{'evalcall_count'} = values %$evalcalls;

                # get list of evals, including nested evals
                my @eval_fis = map { ($_, $_->has_evals(1)) } values %$evalcalls;
                $line_stats->{'evalcall_count_nested'} = @eval_fis;
                $line_stats->{'evalcall_stmts_time_nested'} = sum(
                    map { $_->sum_of_stmts_time } @eval_fis);
            }

            if (my $stmts = $lines_array->[$linenum]) {
                next if !@$stmts; # XXX happens for evals, investigate

                my ($stmt_time, $stmt_count) = @$stmts;
                my $line_stats = $stats_by_line{$linenum} ||= {};

                # The debugger cannot stop on BEGIN{...} lines.  A line in a begin
                # may set a scalar reference to something that needs to be eval'd later.
                # as a result, if the variable is expanded outside of the BEGIN, we'll
                # see the original BEGIN line, but it won't have any calls or times
                # associated. This will cause a divide by zero error.
                $stmt_count ||= 1;

                $line_stats->{'time'}  = $stmt_time;
                $line_stats->{'calls'} = $stmt_count;
                $line_stats->{'time/call'} = $stmt_time/$stmt_count;

                push @{$stats_accum{$_}}, $line_stats->{$_}
                    for (qw(time calls time/call));

                $runningTotalTime  += $stmt_time;
                $runningTotalCalls += $stmt_count;
            }

            warn "$linenum: @{[ %{ $stats_by_line{$linenum} } ]}\n"
                if trace_level() >= 3 && $stats_by_line{$linenum};
        }

        warn "unprocessed keys in subdefs_at_line: @{[ keys %$subdefs_at_line ]}\n"
            if %$subdefs_at_line;
        warn "unprocessed keys in subcalls_at_line: @{[ keys %$subcalls_at_line ]}\n"
            if %$subcalls_at_line;
        warn "unprocessed keys in evals_at_line: @{[ keys %$evals_at_line ]}\n"
            if %$evals_at_line;

        $meta->{'time'}      = $runningTotalTime;
        $meta->{'calls'}     = $runningTotalCalls;
        $meta->{'time/call'} =
            ($runningTotalCalls) ? $runningTotalTime / $runningTotalCalls: 0;

        # Use Median Absolute Deviation Formula to get file deviations for each of
        # calls, time and time/call values
        my %stats_for_file = (
            'calls'     => calculate_median_absolute_deviation($stats_accum{'calls'}||[]),
            'time'      => calculate_median_absolute_deviation($stats_accum{'time'}||[]),
            'time/call' => calculate_median_absolute_deviation($stats_accum{'time/call'}||[]),
            subcall_count => calculate_median_absolute_deviation($stats_accum{subcall_count}||[]),
            subcall_time  => calculate_median_absolute_deviation($stats_accum{subcall_time}||[]),
        );

        # the output file name that will be open later.  Not including directory at this time.
        # keep here so that the variable replacement subs can get at it.
        my $fname = $self->fname_for_fileinfo($fi) . $self->{suffix};

        # localize header and footer for variable replacement
        my $header    = $self->get_param('header',    [$profile, $fi, $fname, $LEVEL]);
        my $datastart = $self->get_param('datastart', [$profile, $fi]);
        my $dataend   = $self->get_param('dataend',   [$profile, $fi]);
        my $FILE      = $filestr;
#warn Dumper(\%stats_by_line);
        # open output file
        #warn "$self->{output_dir}/$fname";
        open(OUT, ">", "$self->{output_dir}/$fname")
            or confess "Unable to open $self->{output_dir}/$fname " . "for writing: $!\n";

        # begin output
        print OUT $header;

        # If we don't have savesrc for the file then we'll be reading the current
        # file contents which may have changed since the profile was run.
        # In this case we need to warn the user as the report would be garbled.
        print OUT $self->get_param('taintmsg', [$profile, $fi])
            if !$fi->has_savesrc and $self->file_has_been_modified($filestr);

        print OUT $self->get_param('sawampersand', [$profile, $fi])
            if $profile->{attribute}{sawampersand_fid}
            && $fi->fid == $profile->{attribute}{sawampersand_fid};

        print OUT $self->get_param('merged_fids', [$profile, $fi])
            if $fi->meta->{merged_fids};

        print OUT $datastart;

        my $LINE = 1;    # line number in source code
        my $src_lines = $fi->srclines_array;
        if (!$src_lines) { # no savesrc, and no file available

            my $msg;
            if ($fi->is_fake) {
                # eg the "/unknown-eval-invoker"
                $msg = "No source code available for synthetic (fake) file $filestr.",
            }
            elsif ($fi->is_eval) {
                $msg = "No source code available for string eval $filestr.\nYou probably need to use a more recent version of perl. See savesrc option in documentation.",
            }
            elsif ($filestr =~ m{^/loader/0x[0-9a-zA-Z]+/}) {
                # a synthetic file name that perl assigns when reading
                # code returned by a CODE ref in @INC
                $msg = "No source code available for 'file' loaded via CODE reference in \@INC.\nSee savesrc option in documentation.",
            }
            elsif (not $fi->is_file) {
                $msg = "No source code available for non-file '$filestr'.\nYou probably need to use a more recent version of perl. See savesrc option in documentation.",
            }
            else {
                $msg = "Unable to open '$filestr' for reading: $!";

                # clarify some current Moose limitations XXX
                if ($filestr =~ m!/(accessor .*) defined at /!) {
                    $msg = "Source for generated Moose $1 isn't available ($filestr: $!)";
                }
                elsif ($filestr =~ m!/(generated method \(unknown origin\))!) {
                    $msg = "Source for Moose $1 isn't available ($filestr: $!)";
                }

                # the report will not be complete, but this doesn't need to be fatal
                my $hint = '';
                $hint .= " Try running $0 in the same directory as you ran Devel::NYTProf, "
                      . "or ensure \@INC is correct."
                    if $filestr ne '-e'
                    and $filestr !~ m:^/:
                    and not our $_generate_report_inc_hint++;                # only once

                warn "$msg$hint\n"
                    unless our $_generate_report_filestr_warn->{$filestr}++; # only once per filestr

            }

            $src_lines = [ $msg ];
            $LINE = 0; # start numbering from 0 to flag fake contents
        }

        # ensure we don't have any undef source lines
        # (to avoid warnings from the code below)
        my $src_undefs;
        defined $_ or $_ = '' && ++$src_undefs for @$src_lines;
        # XXX shouldn't be need but don't have a test case so grumble
        # about it in the hope of getting a test case
        warn sprintf "Saw %d missing (undef) lines in the %d lines of source code for %s\n",
                $src_undefs, scalar @$src_lines, $filestr
            if $src_undefs;

        # Since we use @$src_lines to drive the report generation, pad the array to
        # ensure it has enough lines to include all the available profile info.
        # Then the report is still useful even if we have no source code.
        push @$src_lines, '' while @$src_lines < $max_linenum-1;

        if (my $z = $stats_by_line{0}) {
            # typically indicates cases where we could do better
            if (trace_level()) {
                warn "$filestr has unexpected info for line 0: @{[ %$z ]}\n";
                # sub defs: used to be xsubs but they're handled separately now
                # so there are no known causes of this any more
                if (my $i = $z->{subdef_info}) {
                    warn "0: @{[ map { $_->subname } @$i ]}\n"
                }
                # sub calls: they're typically END blocks that appear to be
                # invoked from the main .pl script perl ran.
                # Also some BEGINs and things like main::CORE:ftfile
                # (see CPANDB's cpangraph script for some examples)
                if (my $i = $z->{subcall_info}) {
                    warn sprintf "0: called %20s %s\n", $_, join " ", @{ $i->{$_} }
                        for sort keys %$i;
                }
            }

            $LINE = 0;
            unshift @$src_lines, "Profile data that couldn't be associated with a specific line:";
        }

        my $line_sub = $self->{mk_report_source_line}
            or die "mk_report_source_line not set";

        my $prev_line = '-';
        while ( @$src_lines ) {
            my $line = shift @$src_lines;
            chomp $line;

            # detect a series of blank lines, e.g. a chunk of pod savesrc didn't store
            my $skip_blanks = (
                $prev_line eq '' && $line eq '' &&            # blank behind and here
                @$src_lines && $src_lines->[0] =~ /^\s*$/ &&  # blank ahead
                !$stats_by_line{$LINE}                        # nothing to report
            );

            if ($line =~ m/^\# \s* line \s+ (\d+) \b/x) {
                # XXX we should be smarter about this - patches welcome!
                # We should at least ignore the common AutoSplit case
                # which we detect and workaround elsewhere.
                warn "Ignoring '$line' directive at line $LINE - profile data for $filestr will be out of sync with source\n"
                    unless our $line_directive_warn->{$filestr}++; # once per file
            }

            print OUT $line_sub->(
                ($skip_blanks) ? "- -" : $LINE, $line,
                $stats_by_line{$LINE} || {},
                \%stats_for_file,
                $profile,
                $fi,
            );

            if ($skip_blanks) {
                while (
                    @$src_lines && $src_lines->[0] =~ /^\s*$/ &&
                    !$stats_by_line{$LINE+1}
                ) {
                    shift @$src_lines;
                    $LINE++;
                }
            }
            $prev_line = $line;
        }
        continue {
            $LINE++;
        }

        my $separator_sub = $self->{mk_report_separator_line};

        # iterate over xsubs 
        $line_sub = $self->{mk_report_xsub_line}
            or die "mk_report_xsub_line not set";
        my $subs_defined_in_file = $profile->subs_defined_in_file($filestr);
        foreach my $subname (sort keys %$subs_defined_in_file) {
            my $subinfo = $subs_defined_in_file->{$subname};
            my $kind = $subinfo->kind;

            next if $kind eq 'perl';
            next if $subinfo->calls == 0;

            if ($separator_sub) {
                print OUT $separator_sub->($profile, $fi);
                undef $separator_sub; # do mk_report_separator_line just once
            }

            print OUT $line_sub->(
                $subname,
                "sub $subname; # $kind\n\t",
                { subdef_info => [ $subinfo ], },  #stats_for_line
                undef, # stats_for_file
                $profile, $fi
            );
        }

        print OUT $dataend;
        print OUT $self->get_param('footer', [$profile, $filestr]);
        close OUT;
    }
    print "\n" if $opts{show_progress};
}


sub url_for_file {
    my ($self, $file, $anchor, $level) = @_;
    confess "No file specified" unless $file;
    $level ||= '';

    my $url = $self->{_cache}{"url_for_file,$file,$level"} ||= do {
        my $fi = $self->{profile}->fileinfo_of($file);
        $level = 'line' if $fi->is_eval;
        $self->fname_for_fileinfo($fi, $level) . ".html";
    };

    $url .= "#$anchor" if defined $anchor;
    return $url;
}

sub href_for_file {
    my $url = shift->url_for_file(@_);
    return qq{href="$url"} if $url;
    return $url;
}


sub url_for_sub {
    my ($self, $sub, %opts) = @_;
    my $profile = $self->{profile};

    my ($file, $fid, $first, $last, $fi) = $profile->file_line_range_of_sub($sub);
    return "" unless $file;
    if (!$first) {
        # use sanitized subname as label for xsubs
        # XXX must match what nytprofhtml does for xsubs
        ($first = $sub) =~ s/\W/_/g;
    }
    return $self->url_for_file($fi, $first);
}

sub href_for_sub {
    my $url = shift->url_for_sub(@_);
    return qq{href="$url"} if $url;
    return $url;
}


1;