File Coverage

blib/lib/Devel/NYTProf/Reader.pm
Criterion Covered Total %
statement 230 274 83.9
branch 77 134 57.4
condition 41 81 50.6
subroutine 25 25 100.0
pod 0 12 0.0
total 373 526 70.9


line stmt bran cond sub pod time code
1             # vim: ts=8 sw=4 expandtab:
2             ##########################################################
3             ## This script is part of the Devel::NYTProf distribution
4             ##
5             ## Copyright, contact and other information can be found
6             ## at the bottom of this file, or by going to:
7             ## http://metacpan.org/release/Devel-NYTProf/
8             ##
9             ###########################################################
10             package Devel::NYTProf::Reader;
11              
12             our $VERSION = '6.13_003';
13              
14 47     47   26581 use warnings;
  47         133  
  47         1573  
15 47     47   267 use strict;
  47         122  
  47         963  
16 47     47   248 use Carp;
  47         96  
  47         2537  
17 47     47   285 use Config;
  47         99  
  47         1843  
18              
19 47     47   283 use List::Util qw(sum max);
  47         98  
  47         3271  
20 47     47   2127 use Data::Dumper;
  47         20671  
  47         2622  
21              
22 47     47   1835 use Devel::NYTProf::Data;
  47         144  
  47         2096  
23 47         3530 use Devel::NYTProf::Util qw(
24             html_safe_filename
25             calculate_median_absolute_deviation
26             trace_level
27 47     47   314 );
  47         148  
28              
29             # These control the limits for what the script will consider ok to severe times
30             # specified in standard deviations from the mean time
31 47     47   385 use constant SEVERITY_SEVERE => 2.0; # above this deviation, a bottleneck
  47         139  
  47         3453  
32 47     47   318 use constant SEVERITY_BAD => 1.0;
  47         119  
  47         2639  
33 47     47   311 use constant SEVERITY_GOOD => 0.5; # within this deviation, okay
  47         135  
  47         177463  
34              
35              
36             # Static class variables
37             our $FLOAT_FORMAT = $Config{nvfformat};
38             $FLOAT_FORMAT =~ s/"//g;
39              
40             # Class methods
41             sub new {
42 3     3 0 805 my $class = shift;
43 3         8 my $file = shift;
44 3   50     13 my $opts = shift || {};
45              
46 3   50     84 my $self = {
47             file => $file || 'nytprof.out',
48             output_dir => '.',
49             suffix => '.csv',
50             header => "# Profile data generated by Devel::NYTProf::Reader\n"
51             . "# Version: v$Devel::NYTProf::Core::VERSION\n"
52             . "# More information at http://metacpan.org/release/Devel-NYTProf/\n"
53             . "# Format: time,calls,time/call,code\n",
54             datastart => '',
55             mk_report_source_line => undef,
56             mk_report_xsub_line => undef,
57             mk_report_separator_line => undef,
58             line => [
59             {},
60             {value => 'time', end => ',', default => '0'},
61             {value => 'calls', end => ',', default => '0'},
62             {value => 'time/call', end => ',', default => '0'},
63             {value => 'source', end => '', default => ''},
64             {end => "\n"}
65             ],
66             dataend => '',
67             footer => '',
68             merged_fids => '',
69             taintmsg => "# WARNING!\n"
70             . "# The source file used in generating this report has been modified\n"
71             . "# since generating the profiler database. It might be out of sync\n",
72             sawampersand => "# NOTE!\n"
73             . "# This file uses special regexp match variables that impact the performance\n"
74             . "# of all regular expression in the program!\n"
75             . "# See WARNING in http://perldoc.perl.org/perlre.html#Capture-buffers\n",
76             current_level => '',
77             };
78              
79 3         10 bless($self, $class);
80             $self->{profile} = Devel::NYTProf::Data->new({
81             %$opts,
82             filename => $self->{file},
83 3         42 });
84              
85 3         12 return $self;
86             }
87              
88              
89              
90             ##
91             sub set_param {
92 4     4 0 1327 my ($self, $param, $value) = @_;
93              
94 4 100       14 if (!exists $self->{$param}) {
95 1         209 confess "Attempt to set $param to $value failed: $param is not a valid " . "parameter\n";
96             }
97             else {
98 3 100       13 return $self->{$param} unless defined($value);
99 2         5 $self->{$param} = $value;
100             }
101 2         5 undef;
102             }
103              
104              
105             sub get_param {
106 15     15 0 589 my ($self, $param, $code_args) = @_;
107 15         28 my $value = $self->{$param};
108 15 100       37 if (ref $value eq 'CODE') {
109 1   50     8 $code_args ||= [];
110 1         4 $value = $value->(@$code_args);
111             }
112 15         38 return $value;
113             }
114              
115             ##
116             sub file_has_been_modified {
117 4     4 0 10 my $self = shift;
118 4         7 my $file = shift;
119 4 50       117 return undef unless -f $file;
120 0         0 my $mtime = (stat $file)[9];
121 0         0 return ($mtime > $self->{profile}{attribute}{basetime});
122             }
123              
124             ##
125             sub _output_additional {
126 1     1   1086 my ($self, $fname, $content) = @_;
127 1 50       72 open(OUT, '>', "$self->{output_dir}/$fname")
128             or confess "Unable to open $self->{output_dir}/$fname for writing; $!\n";
129 1         8 print OUT $content;
130 1         38 close OUT;
131             }
132              
133             ##
134             sub output_dir {
135 2     2 0 1568 my ($self, $dir) = @_;
136 2 100       11 return $self->{output_dir} unless defined($dir);
137 1 50       13 if (!mkdir $dir) {
138 1 50       16 confess "Unable to create directory $dir: $!\n" if !$! =~ /exists/;
139             }
140 1         8 $self->{output_dir} = $dir;
141             }
142              
143             ##
144             sub report {
145 1     1 0 3 my $self = shift;
146 1         3 my ($opts) = @_;
147              
148 1         2 my $level_additional_sub = $opts->{level_additional};
149 1         3 my $profile = $self->{profile};
150 1         5 my $modes = $profile->get_profile_levels;
151 1         4 my @levels = grep { {reverse %$modes}->{$_} } qw(sub block line);
  3         19  
152 1         5 for my $level (@levels) {
153             print "Writing $level reports to $self->{output_dir} directory\n"
154 3 50       7 unless $opts->{quiet};
155             $self->_generate_report($profile, $level,
156 3   33     16 show_progress => (not $opts->{quiet} and -t STDOUT)
157             );
158 3 50       12 $level_additional_sub->($profile, $level)
159             if $level_additional_sub;
160             }
161             }
162              
163             sub current_level {
164 12     12 0 28 my $self = shift;
165 12 100       33 $self->{current_level} = shift if @_;
166 12   100     54 return $self->{current_level} || 'line';
167             }
168              
169             sub fname_for_fileinfo {
170 10     10 0 1232 my ($self, $fi, $level) = @_;
171 10 100       160 confess "No fileinfo" unless $fi;
172 9   66     28 $level ||= $self->current_level;
173              
174 9         26 my $fname = $fi->filename_without_inc;
175              
176             # We want to have descriptive and unambiguous filename
177             # but we don't want to risk failure due to filenames being longer
178             # than MAXPATH (including the length of whatever dir we're writing
179             # the report files into). So we truncate to the last component if
180             # the filenames seems 'dangerously long'. XXX be smarter about this.
181             # This is safe from ambiguity because we add the fid to the filename below.
182 9   50     39 my $max_len = $ENV{NYTPROF_FNAME_TRIM} || 50;
183 9 50       59 $fname =~ s!/.*/!/.../! if length($fname) > $max_len; # remove dir path
184 9 50       24 $fname = "TOOLONG" if length($fname) > $max_len; # just in case
185              
186 9         26 $fname = html_safe_filename($fname);
187 9         26 $fname .= "-".$fi->fid; # to ensure uniqueness and for info
188 9 50       25 $fname .= "-$level" if $level;
189              
190 9         31 return $fname;
191             }
192              
193              
194             ##
195             sub _generate_report {
196 3     3   6 my $self = shift;
197 3         13 my ($profile, $LEVEL, %opts) = @_;
198              
199 3         9 $self->current_level($LEVEL);
200              
201 3 50       13 my @all_fileinfos = $profile->all_fileinfos
202             or carp "Profile report data contains no files";
203              
204 3         7 my @fis = @all_fileinfos;
205 3 100       9 if ($LEVEL ne 'line') {
206             # we only generate line-level reports for evals
207             # for efficiency and because some data model editing only
208             # is only implemented for line-level data
209 2         4 @fis = grep { not $_->is_eval } @fis;
  2         6  
210             }
211              
212 3         4 my $progress;
213 3         7 foreach my $fi (@fis) {
214              
215 3 50       8 if ($opts{show_progress}) {
216 0         0 local $| = 1;
217 0         0 ++$progress;
218 0         0 printf "\r %3d%% ... ", $progress/@fis*100;
219             }
220              
221 3         9 my $meta = $fi->meta;
222 3         9 my $filestr = $fi->filename;
223              
224             # { linenumber => { subname => [ count, time ] } }
225 3         6 my $subcalls_at_line = { %{ $fi->sub_call_lines } };
  3         8  
226 3   50     32 my $subcalls_max_line = max( keys %$subcalls_at_line ) || 0;
227              
228             # { linenumber => [ $subinfo, ... ] }
229 3         8 my $subdefs_at_line = { %{ $profile->subs_defined_in_file_by_line($filestr) } };
  3         10  
230 3   50     24 my $subdefs_max_line = max( keys %$subdefs_at_line ) || 0;
231 3         9 delete $subdefs_at_line->{0}; # xsubs handled separately
232              
233             # { linenumber => { fid => $fileinfo } }
234 3         5 my $evals_at_line = { %{ $fi->evals_by_line } };
  3         17  
235 3   50     15 my $evals_max_line = max( keys %$evals_at_line ) || 0;
236              
237             # note that a file may have no source lines executed, so no keys here
238             # (but is included because some xsubs in the package were executed)
239 3   50     11 my $lines_array = $fi->line_time_data([$LEVEL]) || [];
240 3         9 my $src_max_line = scalar @$lines_array;
241              
242 3         8 for ($src_max_line, $subcalls_max_line, $subdefs_max_line, $evals_max_line) {
243 12 50       27 next if $_ < 2**16;
244 0         0 warn "Ignoring indication that $filestr has $_ lines! (Possibly corrupt data)\n";
245 0         0 $_ = 0;
246             }
247              
248 3         8 my $max_linenum = max(
249             $src_max_line,
250             $subcalls_max_line,
251             $subdefs_max_line,
252             $evals_max_line,
253             );
254              
255 3 50 33     19 warn sprintf "%s max lines: %s (stmts %s, subcalls %s, subdefs %s, evals %s)\n",
256             $filestr, $max_linenum, scalar @$lines_array,
257             $subcalls_max_line, $subdefs_max_line, $evals_max_line
258             if trace_level() >= 4 or $max_linenum > 2**15;
259              
260 3         6 my %stats_accum; # holds all line times. used to find median
261             my %stats_by_line; # holds individual line stats
262 3         5 my $runningTotalTime = 0; # holds the running total
263             # (should equal sum of $stats_accum)
264 3         5 my $runningTotalCalls = 0; # holds the running total number of calls.
265              
266 3         9 for (my $linenum = 0; $linenum <= $max_linenum; ++$linenum) {
267              
268 60 100       119 if (my $subdefs = delete $subdefs_at_line->{$linenum}) {
269 9         28 $stats_by_line{$linenum}->{'subdef_info'} = $subdefs;
270             }
271              
272 60 100       120 if (my $subcalls = delete $subcalls_at_line->{$linenum}) {
273 27   50     84 my $line_stats = $stats_by_line{$linenum} ||= {};
274              
275 27         55 $line_stats->{'subcall_info'} = $subcalls;
276 27         57 $line_stats->{'subcall_count'} = sum(map { $_->[0] } values %$subcalls);
  27         72  
277 27         50 $line_stats->{'subcall_time'} = sum(map { $_->[1] } values %$subcalls);
  27         58  
278              
279 54         123 push @{$stats_accum{$_}}, $line_stats->{$_}
280 27         50 for (qw(subcall_count subcall_time));
281             }
282              
283 60 50       108 if (my $evalcalls = delete $evals_at_line->{$linenum}) {
284 0   0     0 my $line_stats = $stats_by_line{$linenum} ||= {};
285              
286             # %$evals => { fid => $fileinfo }
287 0         0 $line_stats->{'evalcall_info'} = $evalcalls;
288 0         0 $line_stats->{'evalcall_count'} = values %$evalcalls;
289              
290             # get list of evals, including nested evals
291 0         0 my @eval_fis = map { ($_, $_->has_evals(1)) } values %$evalcalls;
  0         0  
292 0         0 $line_stats->{'evalcall_count_nested'} = @eval_fis;
293             $line_stats->{'evalcall_stmts_time_nested'} = sum(
294 0         0 map { $_->sum_of_stmts_time } @eval_fis);
  0         0  
295             }
296              
297 60 100       123 if (my $stmts = $lines_array->[$linenum]) {
298 21 50       36 next if !@$stmts; # XXX happens for evals, investigate
299              
300 21         38 my ($stmt_time, $stmt_count) = @$stmts;
301 21   50     44 my $line_stats = $stats_by_line{$linenum} ||= {};
302              
303             # The debugger cannot stop on BEGIN{...} lines. A line in a begin
304             # may set a scalar reference to something that needs to be eval'd later.
305             # as a result, if the variable is expanded outside of the BEGIN, we'll
306             # see the original BEGIN line, but it won't have any calls or times
307             # associated. This will cause a divide by zero error.
308 21   50     38 $stmt_count ||= 1;
309              
310 21         30 $line_stats->{'time'} = $stmt_time;
311 21         44 $line_stats->{'calls'} = $stmt_count;
312 21         36 $line_stats->{'time/call'} = $stmt_time/$stmt_count;
313              
314 63         141 push @{$stats_accum{$_}}, $line_stats->{$_}
315 21         35 for (qw(time calls time/call));
316              
317 21         28 $runningTotalTime += $stmt_time;
318 21         31 $runningTotalCalls += $stmt_count;
319             }
320              
321 0         0 warn "$linenum: @{[ %{ $stats_by_line{$linenum} } ]}\n"
  0         0  
322 60 0 33     205 if trace_level() >= 3 && $stats_by_line{$linenum};
323             }
324              
325 3 50       7 warn "unprocessed keys in subdefs_at_line: @{[ keys %$subdefs_at_line ]}\n"
  0         0  
326             if %$subdefs_at_line;
327 3 50       8 warn "unprocessed keys in subcalls_at_line: @{[ keys %$subcalls_at_line ]}\n"
  0         0  
328             if %$subcalls_at_line;
329 3 50       12 warn "unprocessed keys in evals_at_line: @{[ keys %$evals_at_line ]}\n"
  0         0  
330             if %$evals_at_line;
331              
332 3         9 $meta->{'time'} = $runningTotalTime;
333 3         7 $meta->{'calls'} = $runningTotalCalls;
334 3 50       9 $meta->{'time/call'} =
335             ($runningTotalCalls) ? $runningTotalTime / $runningTotalCalls: 0;
336              
337             # Use Median Absolute Deviation Formula to get file deviations for each of
338             # calls, time and time/call values
339             my %stats_for_file = (
340             'calls' => calculate_median_absolute_deviation($stats_accum{'calls'}||[]),
341             'time' => calculate_median_absolute_deviation($stats_accum{'time'}||[]),
342             'time/call' => calculate_median_absolute_deviation($stats_accum{'time/call'}||[]),
343             subcall_count => calculate_median_absolute_deviation($stats_accum{subcall_count}||[]),
344 3   50     17 subcall_time => calculate_median_absolute_deviation($stats_accum{subcall_time}||[]),
      50        
      50        
      50        
      50        
345             );
346              
347             # the output file name that will be open later. Not including directory at this time.
348             # keep here so that the variable replacement subs can get at it.
349 3         12 my $fname = $self->fname_for_fileinfo($fi) . $self->{suffix};
350              
351             # localize header and footer for variable replacement
352 3         11 my $header = $self->get_param('header', [$profile, $fi, $fname, $LEVEL]);
353 3         11 my $datastart = $self->get_param('datastart', [$profile, $fi]);
354 3         8 my $dataend = $self->get_param('dataend', [$profile, $fi]);
355 3         7 my $FILE = $filestr;
356             #warn Dumper(\%stats_by_line);
357             # open output file
358             #warn "$self->{output_dir}/$fname";
359 3 50       221 open(OUT, ">", "$self->{output_dir}/$fname")
360             or confess "Unable to open $self->{output_dir}/$fname " . "for writing: $!\n";
361              
362             # begin output
363 3         34 print OUT $header;
364              
365             # If we don't have savesrc for the file then we'll be reading the current
366             # file contents which may have changed since the profile was run.
367             # In this case we need to warn the user as the report would be garbled.
368 3 50 33     46 print OUT $self->get_param('taintmsg', [$profile, $fi])
369             if !$fi->has_savesrc and $self->file_has_been_modified($filestr);
370              
371             print OUT $self->get_param('sawampersand', [$profile, $fi])
372             if $profile->{attribute}{sawampersand_fid}
373 3 50 33     14 && $fi->fid == $profile->{attribute}{sawampersand_fid};
374              
375             print OUT $self->get_param('merged_fids', [$profile, $fi])
376 3 50       11 if $fi->meta->{merged_fids};
377              
378 3         8 print OUT $datastart;
379              
380 3         5 my $LINE = 1; # line number in source code
381 3         9 my $src_lines = $fi->srclines_array;
382 3 50       8 if (!$src_lines) { # no savesrc, and no file available
383              
384 3         6 my $msg = '';
385 3 50       9 if ($fi->is_fake) {
    50          
    50          
    50          
386             # eg the "/unknown-eval-invoker"
387 0         0 $msg = "No source code available for synthetic (fake) file $filestr.",
388             }
389             elsif ($fi->is_eval) {
390 0         0 $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.",
391             }
392             elsif ($filestr =~ m{^/loader/0x[0-9a-zA-Z]+/}) {
393             # a synthetic file name that perl assigns when reading
394             # code returned by a CODE ref in @INC
395 0         0 $msg = "No source code available for 'file' loaded via CODE reference in \@INC.\nSee savesrc option in documentation.",
396             }
397             elsif (not $fi->is_file) {
398 0         0 $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.",
399             }
400             else {
401 3 50       16 $msg = "Unable to open '$filestr' for reading: $!"
402             unless $filestr =~ m{t/test01\.p$};
403              
404             # clarify some current Moose limitations XXX
405 3 50       11 if ($filestr =~ m!/(accessor .*) defined at /!) {
    50          
406 0         0 $msg = "Source for generated Moose $1 isn't available ($filestr: $!)";
407             }
408             elsif ($filestr =~ m!/(generated method \(unknown origin\))!) {
409 0         0 $msg = "Source for Moose $1 isn't available ($filestr: $!)";
410             }
411              
412             # the report will not be complete, but this doesn't need to be fatal
413 3         6 my $hint = '';
414 3 50 33     17 $hint .= " Try running $0 in the same directory as you ran Devel::NYTProf, "
      33        
415             . "or ensure \@INC is correct."
416             if $filestr ne '-e'
417             and $filestr !~ m:^/:
418             and not our $_generate_report_inc_hint++; # only once
419              
420             # If neither $msg nor $hint has been populated, no need to
421             # warn, thereby avoiding superfluous new line in test output
422 3 50 33     23 if ($msg or $hint) {
423             warn "$msg$hint\n"
424             # only once per filestr
425 0 0       0 unless our $_generate_report_filestr_warn->{$filestr}++;
426             }
427              
428             }
429              
430 3         10 $src_lines = [ $msg ];
431 3         15 $LINE = 0; # start numbering from 0 to flag fake contents
432             }
433              
434             # ensure we don't have any undef source lines
435             # (to avoid warnings from the code below)
436 3         6 my $src_undefs;
437 3   50     11 defined $_ or $_ = '' && ++$src_undefs for @$src_lines;
438             # XXX shouldn't be need but don't have a test case so grumble
439             # about it in the hope of getting a test case
440 3 50       6 warn sprintf "Saw %d missing (undef) lines in the %d lines of source code for %s\n",
441             $src_undefs, scalar @$src_lines, $filestr
442             if $src_undefs;
443              
444             # Since we use @$src_lines to drive the report generation, pad the array to
445             # ensure it has enough lines to include all the available profile info.
446             # Then the report is still useful even if we have no source code.
447 3         53 push @$src_lines, '' while @$src_lines < $max_linenum-1;
448              
449 3 50       9 if (my $z = $stats_by_line{0}) {
450             # typically indicates cases where we could do better
451 0 0       0 if (trace_level()) {
452 0         0 warn "$filestr has unexpected info for line 0: @{[ %$z ]}\n";
  0         0  
453             # sub defs: used to be xsubs but they're handled separately now
454             # so there are no known causes of this any more
455 0 0       0 if (my $i = $z->{subdef_info}) {
456 0         0 warn "0: @{[ map { $_->subname } @$i ]}\n"
  0         0  
  0         0  
457             }
458             # sub calls: they're typically END blocks that appear to be
459             # invoked from the main .pl script perl ran.
460             # Also some BEGINs and things like main::CORE:ftfile
461             # (see CPANDB's cpangraph script for some examples)
462 0 0       0 if (my $i = $z->{subcall_info}) {
463 0         0 warn sprintf "0: called %20s %s\n", $_, join " ", @{ $i->{$_} }
464 0         0 for sort keys %$i;
465             }
466             }
467              
468 0         0 $LINE = 0;
469 0         0 unshift @$src_lines, "Profile data that couldn't be associated with a specific line:";
470             }
471              
472             my $line_sub = $self->{mk_report_source_line}
473 3 50       11 or die "mk_report_source_line not set";
474              
475 3         10 my $prev_line = '-';
476 3         9 while ( @$src_lines ) {
477 45         61 my $line = shift @$src_lines;
478 45         63 chomp $line;
479              
480             # detect a series of blank lines, e.g. a chunk of pod savesrc didn't store
481             my $skip_blanks = (
482             $prev_line eq '' && $line eq '' && # blank behind and here
483             @$src_lines && $src_lines->[0] =~ /^\s*$/ && # blank ahead
484 45   100     318 !$stats_by_line{$LINE} # nothing to report
485             );
486              
487 45 50       85 if ($line =~ m/^\# \s* line \s+ (\d+) \b/x) {
488             # XXX we should be smarter about this - patches welcome!
489             # We should at least ignore the common AutoSplit case
490             # which we detect and workaround elsewhere.
491             warn "Ignoring '$line' directive at line $LINE - profile data for $filestr will be out of sync with source\n"
492 0 0       0 unless our $line_directive_warn->{$filestr}++; # once per file
493             }
494              
495             print OUT $line_sub->(
496             ($skip_blanks) ? "- -" : $LINE, $line,
497 45 100 100     161 $stats_by_line{$LINE} || {},
498             \%stats_for_file,
499             $profile,
500             $fi,
501             );
502              
503 45 100       803 if ($skip_blanks) {
504 9   33     57 while (
      66        
505             @$src_lines && $src_lines->[0] =~ /^\s*$/ &&
506             !$stats_by_line{$LINE+1}
507             ) {
508 9         15 shift @$src_lines;
509 9         48 $LINE++;
510             }
511             }
512 45         71 $prev_line = $line;
513             }
514             continue {
515 45         85 $LINE++;
516             }
517              
518 3         6 my $separator_sub = $self->{mk_report_separator_line};
519              
520             # iterate over xsubs
521             $line_sub = $self->{mk_report_xsub_line}
522 3 50       8 or die "mk_report_xsub_line not set";
523 3         11 my $subs_defined_in_file = $profile->subs_defined_in_file($filestr);
524 3         18 foreach my $subname (sort keys %$subs_defined_in_file) {
525 18         39 my $subinfo = $subs_defined_in_file->{$subname};
526 18         38 my $kind = $subinfo->kind;
527              
528 18 100       38 next if $kind eq 'perl';
529 6 100       13 next if $subinfo->calls == 0;
530              
531 3 50       7 if ($separator_sub) {
532 0         0 print OUT $separator_sub->($profile, $fi);
533 0         0 undef $separator_sub; # do mk_report_separator_line just once
534             }
535              
536 3         28 print OUT $line_sub->(
537             $subname,
538             "sub $subname; # $kind\n\t",
539             { subdef_info => [ $subinfo ], }, #stats_for_line
540             undef, # stats_for_file
541             $profile, $fi
542             );
543             }
544              
545 3         8 print OUT $dataend;
546 3         9 print OUT $self->get_param('footer', [$profile, $filestr]);
547 3         161 close OUT;
548             }
549 3 50       20 print "\n" if $opts{show_progress};
550             }
551              
552              
553             sub url_for_file {
554 11     11 0 23 my ($self, $file, $anchor, $level) = @_;
555 11 50       24 confess "No file specified" unless $file;
556 11   100     36 $level ||= '';
557              
558 11   66     51 my $url = $self->{_cache}{"url_for_file,$file,$level"} ||= do {
559 4         12 my $fi = $self->{profile}->fileinfo_of($file);
560 4 50       15 $level = 'line' if $fi->is_eval;
561 4         19 $self->fname_for_fileinfo($fi, $level) . ".html";
562             };
563              
564 11 100       32 $url .= "#$anchor" if defined $anchor;
565 11         46 return $url;
566             }
567              
568             sub href_for_file {
569 3     3 0 34 my $url = shift->url_for_file(@_);
570 3 50       20 return qq{href="$url"} if $url;
571 0         0 return $url;
572             }
573              
574              
575             sub url_for_sub {
576 8     8 0 32 my ($self, $sub, %opts) = @_;
577 8         16 my $profile = $self->{profile};
578              
579 8         26 my ($file, $fid, $first, $last, $fi) = $profile->file_line_range_of_sub($sub);
580 8 50       21 return "" unless $file;
581 8 100       17 if (!$first) {
582             # use sanitized subname as label for xsubs
583             # XXX must match what nytprofhtml does for xsubs
584 2         14 ($first = $sub) =~ s/\W/_/g;
585             }
586 8         21 return $self->url_for_file($fi, $first);
587             }
588              
589             sub href_for_sub {
590 4     4 0 12 my $url = shift->url_for_sub(@_);
591 4 50       23 return qq{href="$url"} if $url;
592 0           return $url;
593             }
594              
595              
596             1;