This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
(was Re: DProf tests with -p broken on VMS)
[perl5.git] / utils / dprofpp.PL
1 #!/usr/local/bin/perl
2
3 use Config;
4 use File::Basename qw(&basename &dirname);
5 use File::Spec;
6
7 # List explicitly here the variables you want Configure to
8 # generate.  Metaconfig only looks for shell variables, so you
9 # have to mention them as if they were shell variables, not
10 # %Config entries.  Thus you write
11 #  $startperl
12 # to ensure Configure will look for $Config{startperl}.
13
14 # This forces PL files to create target in same directory as PL file.
15 # This is so that make depend always knows where to find PL derivatives.
16 chdir(dirname($0));
17 ($file = basename($0)) =~ s/\.PL$//;
18 $file =~ s/\.pl$// if ($Config{'osname'} eq 'OS2');      # "case-forgiving"
19 $file =~ s/\.pl$/.com/i if ($Config{'osname'} eq 'VMS');  # "case-forgiving"
20
21 my $dprof_pm = File::Spec->catfile(File::Spec->updir, 'ext', 'Devel', 'DProf', 'DProf.pm');
22 my $VERSION = 0;
23 open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!";
24 while(<PM>){
25         if( /^\$Devel::DProf::VERSION\s*=\s*'([\d._]+)'/ ){
26                 $VERSION = $1;
27                 last;
28         }
29 }
30 close PM;
31 if( $VERSION == 0 ){
32         die "Did not find VERSION in $dprof_pm";
33 }
34 my $stty = 'undef';
35 foreach my $s (qw(/bin/stty /usr/bin/stty)) {
36     if (-x $s) {
37         $stty = qq["$s"];
38         last;
39     }
40 }
41 open OUT,">$file" or die "Can't create $file: $!";
42
43 print "Extracting $file (with variable substitutions)\n";
44
45 # In this section, perl variables will be expanded during extraction.
46 # You can use $Config{...} to use Configure variables.
47
48 print OUT <<"!GROK!THIS!";
49 $Config{'startperl'}
50     eval 'exec perl -S \$0 "\$@"'
51         if 0;
52
53 require 5.003;
54
55 my \$VERSION = '$VERSION';
56 my \$stty    = $stty;
57
58 !GROK!THIS!
59
60 # In the following, perl variables are not expanded during extraction.
61
62 print OUT <<'!NO!SUBS!';
63 =head1 NAME
64
65 dprofpp - display perl profile data
66
67 =head1 SYNOPSIS
68
69 dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
70   
71 dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
72
73 dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
74
75 dprofpp B<-G> <regexp> [B<-P>] [profile]
76  
77 dprofpp B<-p script> [B<-Q>] [other opts]
78
79 dprofpp B<-V> [profile]
80
81 =head1 DESCRIPTION
82
83 The I<dprofpp> command interprets profile data produced by a profiler, such
84 as the Devel::DProf profiler.  Dprofpp will read the file F<tmon.out> and
85 will display the 15 subroutines which are using the most time.  By default
86 the times for each subroutine are given exclusive of the times of their
87 child subroutines.
88
89 To profile a Perl script run the perl interpreter with the B<-d> switch.  So
90 to profile script F<test.pl> with Devel::DProf the following command should
91 be used.
92
93         $ perl5 -d:DProf test.pl
94
95 Then run dprofpp to analyze the profile.  The output of dprofpp depends
96 on the flags to the program and the version of Perl you're using.
97
98         $ dprofpp -u
99         Total Elapsed Time =    1.67 Seconds
100                  User Time =    0.61 Seconds
101         Exclusive Times
102         %Time Seconds     #Calls sec/call Name
103          52.4   0.320          2   0.1600 main::foo
104          45.9   0.280        200   0.0014 main::bar
105          0.00   0.000          1   0.0000 DynaLoader::import
106          0.00   0.000          1   0.0000 main::baz
107
108 The dprofpp tool can also run the profiler before analyzing the profile
109 data.  The above two commands can be executed with one dprofpp command.
110
111         $ dprofpp -u -p test.pl
112
113 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
114
115 =head1 OUTPUT
116
117 Columns are:
118
119 =over 4
120
121 =item %Time
122
123 Percentage of time spent in this routine.
124
125 =item #Calls
126
127 Number of calls to this routine.
128
129 =item sec/call
130
131 Average number of seconds per call to this routine.
132
133 =item Name
134
135 Name of routine.
136
137 =item CumulS
138
139 Time (in seconds) spent in this routine and routines called from it.
140
141 =item ExclSec
142
143 Time (in seconds) spent in this routine (not including those called
144 from it).
145
146 =item Csec/c
147
148 Average time (in seconds) spent in each call of this routine
149 (including those called from it).
150
151 =back
152
153 =head1 OPTIONS
154
155 =over 5
156
157 =item B<-a>
158
159 Sort alphabetically by subroutine names.
160
161 =item B<-d>
162
163 Reverse whatever sort is used
164
165 =item B<-A>
166
167 Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
168 Otherwise the time to autoload it is counted as time of the subroutine
169 itself (there is no way to separate autoload time from run time).
170
171 This is going to be irrelevant with newer Perls.  They will inform
172 C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
173 so a separate statistics for C<AUTOLOAD> will be collected no matter
174 whether this option is set.
175
176 =item B<-R>
177
178 Count anonymous subroutines defined in the same package separately.
179
180 =item B<-E>
181
182 (default)  Display all subroutine times exclusive of child subroutine times.
183
184 =item B<-F>
185
186 Force the generation of fake exit timestamps if dprofpp reports that the
187 profile is garbled.  This is only useful if dprofpp determines that the
188 profile is garbled due to missing exit timestamps.  You're on your own if
189 you do this.  Consult the BUGS section.
190
191 =item B<-I>
192
193 Display all subroutine times inclusive of child subroutine times.
194
195 =item B<-l>
196
197 Sort by number of calls to the subroutines.  This may help identify
198 candidates for inlining.
199
200 =item B<-O cnt>
201
202 Show only I<cnt> subroutines.  The default is 15.
203
204 =item B<-p script>
205
206 Tells dprofpp that it should profile the given script and then interpret its
207 profile data.  See B<-Q>.
208
209 =item B<-Q>
210
211 Used with B<-p> to tell dprofpp to quit after profiling the script, without
212 interpreting the data.
213
214 =item B<-q>
215
216 Do not display column headers.
217
218 =item B<-r>
219
220 Display elapsed real times rather than user+system times.
221
222 =item B<-s>
223
224 Display system times rather than user+system times.
225
226 =item B<-T>
227
228 Display subroutine call tree to stdout.  Subroutine statistics are
229 not displayed.
230
231 =item B<-t>
232
233 Display subroutine call tree to stdout.  Subroutine statistics are not
234 displayed.  When a function is called multiple consecutive times at the same
235 calling level then it is displayed once with a repeat count.
236
237 =item B<-S>
238
239 Display I<merged> subroutine call tree to stdout.  Statistics are
240 displayed for each branch of the tree.  
241
242 When a function is called multiple (I<not necessarily consecutive>)
243 times in the same branch then all these calls go into one branch of
244 the next level.  A repeat count is output together with combined
245 inclusive, exclusive and kids time.
246
247 Branches are sorted w.r.t. inclusive time.
248
249 =item B<-U>
250
251 Do not sort.  Display in the order found in the raw profile.
252
253 =item B<-u>
254
255 Display user times rather than user+system times.
256
257 =item B<-V>
258
259 Print dprofpp's version number and exit.  If a raw profile is found then its
260 XS_VERSION variable will be displayed, too.
261
262 =item B<-v>
263
264 Sort by average time spent in subroutines during each call.  This may help
265 identify candidates for inlining. 
266
267 =item B<-z>
268
269 (default) Sort by amount of user+system time used.  The first few lines
270 should show you which subroutines are using the most time.
271
272 =item B<-g> C<subroutine>
273
274 Ignore subroutines except C<subroutine> and whatever is called from it.
275
276 =item B<-G> <regexp>
277
278 Aggregate "Group" all calls matching the pattern together.
279 For example this can be used to group all calls of a set of packages
280
281   -G "(package1::)|(package2::)|(package3::)"
282
283 or to group subroutines by name:
284
285   -G "getNum"
286
287 =item B<-P>
288
289 Used with -G to aggregate "Pull"  together all calls that did not match -G.
290
291 =item B<-f> <regexp>
292
293 Filter all calls matching the pattern.
294
295 =back
296
297 =head1 ENVIRONMENT
298
299 The environment variable B<DPROFPP_OPTS> can be set to a string containing
300 options for dprofpp.  You might use this if you prefer B<-I> over B<-E> or
301 if you want B<-F> on all the time.
302
303 This was added fairly lazily, so there are some undesirable side effects.
304 Options on the commandline should override options in DPROFPP_OPTS--but
305 don't count on that in this version.
306
307 =head1 BUGS
308
309 Applications which call _exit() or exec() from within a subroutine
310 will leave an incomplete profile.  See the B<-F> option.
311
312 Any bugs in Devel::DProf, or any profiler generating the profile data, could
313 be visible here.  See L<Devel::DProf/BUGS>.
314
315 Mail bug reports and feature requests to the perl5-porters mailing list at
316 F<E<lt>perl5-porters@perl.orgE<gt>>.  Bug reports should include the
317 output of the B<-V> option.
318
319 =head1 FILES
320
321         dprofpp         - profile processor
322         tmon.out        - raw profile
323
324 =head1 SEE ALSO
325
326 L<perl>, L<Devel::DProf>, times(2)
327
328 =cut
329
330 use Getopt::Std 'getopts';
331 use Config '%Config';
332
333 Setup: {
334         my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVS';
335
336         $Monfile = 'tmon.out';
337         if( exists $ENV{DPROFPP_OPTS} ){
338                 my @tmpargv = @ARGV;
339                 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
340                 getopts( $options );
341                 if( @ARGV ){
342                         # there was a filename.
343                         $Monfile = shift;
344                 }
345                 @ARGV = @tmpargv;
346         }
347
348         getopts( $options );
349         if( @ARGV ){
350                 # there was a filename, it overrides any earlier name.
351                 $Monfile = shift;
352         }
353
354 # -O cnt        Specifies maximum number of subroutines to display.
355 # -a            Sort by alphabetic name of subroutines.
356 # -z            Sort by user+system time spent in subroutines. (default)
357 # -l            Sort by number of calls to subroutines.
358 # -v            Sort by average amount of time spent in subroutines.
359 # -T            Show call tree.
360 # -t            Show call tree, compressed.
361 # -q            Do not print column headers.
362 # -u            Use user time rather than user+system time.
363 # -s            Use system time rather than user+system time.
364 # -r            Use real elapsed time rather than user+system time.
365 # -U            Do not sort subroutines.
366 # -E            Sub times are reported exclusive of child times. (default)
367 # -I            Sub times are reported inclusive of child times.
368 # -V            Print dprofpp's version.
369 # -p script     Specifies name of script to be profiled.
370 # -Q            Used with -p to indicate the dprofpp should quit after
371 #               profiling the script, without interpreting the data.
372 # -A            count autoloaded to *AUTOLOAD
373 # -R            count anonyms separately even if from the same package
374 # -g subr       count only those who are SUBR or called from SUBR
375 # -S            Create statistics for all the depths
376
377 # -G            Group all calls matching the pattern together.
378 # -P            Used with -G to pull all other calls together.
379 # -f            Filter all calls mathcing the pattern.
380 # -d            Reverse sort
381
382         if( defined $opt_V ){
383                 my $fh = 'main::fh';
384                 print "$0 version: $VERSION\n";
385                 open( $fh, "<$Monfile" ) && do {
386                         local $XS_VERSION = 'early';
387                         header($fh);
388                         close( $fh );
389                         print "XS_VERSION: $XS_VERSION\n";
390                 };
391                 exit(0);
392         }
393         $cnt = $opt_O || 15;
394         $sort = 'by_time';
395         $sort = 'by_ctime' if defined $opt_I;
396         $sort = 'by_calls' if defined $opt_l;
397         $sort = 'by_alpha' if defined $opt_a;
398         $sort = 'by_avgcpu' if defined $opt_v;
399         
400         if(defined $opt_d){
401                 $sort = "r".$sort;
402         }
403         $incl_excl = 'Exclusive';
404         $incl_excl = 'Inclusive' if defined $opt_I;
405         $whichtime = 'User+System';
406         $whichtime = 'System' if defined $opt_s;
407         $whichtime = 'Real' if defined $opt_r;
408         $whichtime = 'User' if defined $opt_u;
409
410         if( defined $opt_p ){
411                 my $prof = 'DProf';
412                 my $startperl = $Config{'startperl'};
413
414                 $startperl =~ s/^#!//; # remove shebang
415                 run_profiler( $opt_p, $prof, $startperl );
416                 $Monfile = 'tmon.out';  # because that's where it is
417                 exit(0) if defined $opt_Q;
418         }
419         elsif( defined $opt_Q ){
420                 die "-Q is meaningful only when used with -p\n";
421         }
422 }
423
424 Main: {
425         my $monout = $Monfile;
426         my $fh = 'main::fh';
427         local $names = {};
428         local $times = {};   # times in hz
429         local $ctimes = {};  # Cumulative times in hz
430         local $calls = {};
431         local $persecs = {}; # times in seconds
432         local $idkeys = [];
433         local $runtime; # runtime in seconds
434         my @a = ();
435         my $a;
436         local $rrun_utime = 0;  # user time in hz
437         local $rrun_stime = 0;  # system time in hz
438         local $rrun_rtime = 0;  # elapsed run time in hz
439         local $rrun_ustime = 0; # user+system time in hz
440         local $hz = 0;
441         local $deep_times = {count => 0 , kids => {}, incl_time => 0};
442         local $time_precision = 2;
443         local $overhead = 0;
444
445         open( $fh, "<$monout" ) || die "Unable to open $monout\n";
446
447         header($fh);
448
449         $rrun_ustime = $rrun_utime + $rrun_stime;
450
451         $~ = 'STAT';
452         if( ! $opt_q ){
453                 $^ = 'CSTAT_top';
454         }
455
456         parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
457
458         #filter calls
459         if( $opt_f ){
460                 for(my $i = 0;$i < @$idkeys - 2;){
461                         $key = $$idkeys[$i];
462                         if($key =~ /$opt_f/){
463                                 splice(@$idkeys, $i, 1);
464                                 $runtime -= $$times{$key};
465                                 next;
466                         }
467                         $i++;
468                 }
469         }
470
471         if( $opt_G ){
472                 group($names, $calls, $times, $ctimes, $idkeys );
473         }
474
475         settime( \$runtime, $hz ) unless $opt_g;
476
477         exit(0) if $opt_T || $opt_t;
478
479         if( $opt_v ){
480                 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
481         }
482         if( ! $opt_U ){
483                 @a = sort $sort @$idkeys;
484                 $a = \@a;
485         }
486         else {
487                 $a = $idkeys;
488         }
489         display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
490                  $deep_times);
491 }
492
493 sub group{
494         my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
495                 print "Option G Grouping: [$opt_G]\n";
496                 # create entries to store grouping
497                 $$names{$opt_G} = $opt_G;
498                 $$calls{$opt_G} = 0;
499                 $$times{$opt_G} = 0;
500                 $$ctimes{$opt_G} = 0;
501                 $$idkeys[@$idkeys] = $opt_G;
502                 # Sum calls for the grouping
503
504                 my $other = "other";
505                 if($opt_P){
506                         $$names{$other} = $other;
507                         $$calls{$other} = 0;
508                         $$times{$other} = 0;
509                         $$ctimes{$other} = 0;
510                         $$idkeys[@$idkeys] = $other;
511                 }
512
513                 for(my $i = 0;$i < @$idkeys - 2;){
514                         $key = $$idkeys[$i];
515                         if($key =~ /$opt_G/){
516                                 $$calls{$opt_G} += $$calls{$key};
517                                 $$times{$opt_G} += $$times{$key};
518                                 $$ctimes{$opt_G} += $$ctimes{$key};
519                                 splice(@$idkeys, $i, 1);
520                                 next;
521                         }else{
522                                 if($opt_P){
523                                         $$calls{$other} += $$calls{$key};
524                                         $$times{$other} += $$times{$key};
525                                         $$ctimes{$other} += $$ctimes{$key};
526                                         splice(@$idkeys, $i, 1);
527                                         next;
528                                 }
529                         }
530                         $i++;
531                 }
532                 print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
533                           "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
534                           "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
535 }
536
537 # Sets $runtime to user, system, real, or user+system time.  The
538 # result is given in seconds.
539 #
540 sub settime {
541   my( $runtime, $hz ) = @_;
542
543   $hz ||= 1;
544   
545   if( $opt_r ){
546     $$runtime = ($rrun_rtime - $overhead)/$hz;
547   }
548   elsif( $opt_s ){
549     $$runtime = ($rrun_stime - $overhead)/$hz;
550   }
551   elsif( $opt_u ){
552     $$runtime = ($rrun_utime - $overhead)/$hz;
553   }
554   else{
555     $$runtime = ($rrun_ustime - $overhead)/$hz;
556   }
557   $$runtime = 0 unless $$runtime > 0;
558 }
559
560 sub exclusives_in_tree {
561   my( $deep_times ) = @_;
562   my $kids_time = 0;
563   my $kid;
564   # When summing, take into account non-rounded-up kids time.
565   for $kid (keys %{$deep_times->{kids}}) {
566     $kids_time += $deep_times->{kids}{$kid}{incl_time};
567   }
568   $kids_time = 0 unless $kids_time >= 0;
569   $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
570   $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
571   for $kid (keys %{$deep_times->{kids}}) {
572     exclusives_in_tree($deep_times->{kids}{$kid});
573   }
574   $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
575   $deep_times->{kids_time} = $kids_time;
576 }
577
578 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} 
579                    or $a cmp $b }
580
581 sub display_tree {
582   my( $deep_times, $name, $level ) = @_;
583   exclusives_in_tree($deep_times);
584   
585   my $kid;
586
587   my $time;
588   if (%{$deep_times->{kids}}) {
589     $time = sprintf '%.*fs = (%.*f + %.*f)', 
590       $time_precision, $deep_times->{incl_time}/$hz,
591         $time_precision, $deep_times->{excl_time}/$hz,
592           $time_precision, $deep_times->{kids_time}/$hz;
593   } else {
594     $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
595   }
596   print ' ' x (2*$level), "$name x $deep_times->{count}  \t${time}s\n"
597     if $deep_times->{count};
598
599   for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
600     display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
601   }  
602 }
603
604 # Report the times in seconds.
605 sub display {
606         my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, 
607             $idkeys, $deep_times ) = @_;
608         my( $x, $key, $s, $cs );
609         #format: $ncalls, $name, $secs, $percall, $pcnt
610
611         if ($opt_S) {
612           display_tree( $deep_times, 'toplevel', -1 )
613         } else {
614           for( $x = 0; $x < @$idkeys; ++$x ){
615             $key = $idkeys->[$x];
616             $ncalls = $calls->{$key};
617             $name = $names->{$key};
618             $s = $times->{$key}/$hz;
619             $secs = sprintf("%.3f", $s );
620             $cs = $ctimes->{$key}/$hz;
621             $csecs = sprintf("%.3f", $cs );
622             $percall = sprintf("%.4f", $s/$ncalls );
623             $cpercall = sprintf("%.4f", $cs/$ncalls );
624             $pcnt = sprintf("%.2f",
625                             $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
626             write;
627             $pcnt = $secs = $ncalls = $percall = "";
628             write while( length $name );
629             last unless --$cnt;
630           }       
631         }
632 }
633
634 sub move_keys {
635   my ($source, $dest) = @_;
636
637   for my $kid_name (keys %$source) {
638     my $source_kid = delete $source->{$kid_name};
639
640     if (my $dest_kid = $dest->{$kid_name}) {
641       $dest_kid->{count} += $source_kid->{count};
642       $dest_kid->{incl_time} += $source_kid->{incl_time};
643       move_keys($source_kid->{kids},$dest_kid->{kids});
644     } else {
645       $dest->{$kid_name} = $source_kid;
646     }
647   }
648 }
649
650 sub add_to_tree {
651   my ($curdeep_times, $name, $t) = @_;
652   if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
653     $name = $curdeep_times->[-1]{name};
654   }
655   die "Shorted?!" unless @$curdeep_times >= 2;
656   my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
657     count => 0,
658     kids => {}, 
659     incl_time => 0,
660   };
661   # Now transfer to the new node (could not do earlier, since name can change)
662   $entry->{count}++;
663   $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
664   # Merge the kids?
665   move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
666   pop @$curdeep_times;
667 }
668
669
670 sub parsestack {
671         my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
672         my( $dir, $name );
673         my( $t, $syst, $realt, $usert );
674         my( $x, $z, $c, $id, $pack );
675         my @stack = ();
676         my @tstack = ();
677         my %outer;
678         my $tab = 3;
679         my $in = 0;
680
681         # remember last call depth and function name
682         my $l_in = $in;
683         my $l_name = '';
684         my $repcnt = 0;
685         my $repstr = '';
686         my $dprof_stamp;
687         my %cv_hash;
688         my $in_level = not defined $opt_g; # Level deep in report grouping
689         my $curdeep_times = [$deep_times];
690
691         my $over_per_call;
692         if   ( $opt_u ) {       $over_per_call = $over_utime            }
693         elsif( $opt_s ) {       $over_per_call = $over_stime            }
694         elsif( $opt_r ) {       $over_per_call = $over_rtime            }
695         else            {       $over_per_call = $over_utime + $over_stime }
696         $over_per_call /= 2*$over_tests; # distribute over entry and exit
697
698         while(<$fh>){
699                 next if /^#/;
700                 last if /^PART/;
701
702                 chop;
703                 if (/^&/) {
704                   ($dir, $id, $pack, $name) = split;
705                   if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
706                     $name .= "($id)";
707                   }
708                   $cv_hash{$id} = "$pack\::$name";
709                   next;
710                 }
711                 ($dir, $usert, $syst, $realt, $name) = split;
712
713                 my $ot = $t;
714                 if ( $dir eq '/' ) {
715                   $syst = $stack[-1][0];
716                   $usert = '&';
717                   $dir = '-';
718                   #warn("Inserted exit for $stack[-1][0].\n")
719                 }
720                 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
721                   if   ( $opt_u )       {       $t = $usert             }
722                   elsif( $opt_s )       {       $t = $syst              }
723                   elsif( $opt_r )       {       $t = $realt             }
724                   else                  {       $t = $usert + $syst     }
725                   $t += $ot, next if $dir eq '@'; # Increments there
726                 } else {
727                   # "- id" or "- & name"
728                   $name = defined $syst ? $syst : $cv_hash{$usert};
729                 }
730
731                 next unless $in_level or $name eq $opt_g;
732                 if ( $dir eq '-' or $dir eq '*' ) {
733                         my $ename = $dir eq '*' ? $stack[-1][0]  : $name;
734                         $overhead += $over_per_call;
735                         if ($name eq "Devel::DProf::write") {
736                           $overhead += $t - $dprof_stamp;
737                           next;
738                         } elsif (defined $opt_g and $ename eq $opt_g) {
739                           $in_level--;
740                         }
741                         add_to_tree($curdeep_times, $ename,
742                                     $t - $overhead) if $opt_S;
743                         exitstamp( \@stack, \@tstack, 
744                                    $t - $overhead, 
745                                    $times, $ctimes, $ename, \$in, $tab, 
746                                    $curdeep_times, \%outer );
747                 } 
748                 next unless $in_level or $name eq $opt_g;
749                 if( $dir eq '+' or $dir eq '*' ){
750                         if ($name eq "Devel::DProf::write") {
751                           $dprof_stamp = $t;
752                           next;
753                         } elsif (defined $opt_g and $name eq $opt_g) {
754                           $in_level++;
755                         }
756                         $overhead += $over_per_call;
757                         if( $opt_T ){
758                                 print ' ' x $in, "$name\n";
759                                 $in += $tab;
760                         }
761                         elsif( $opt_t ){
762                                 # suppress output on same function if the
763                                 # same calling level is called.
764                                 if ($l_in == $in and $l_name eq $name) {
765                                         $repcnt++;
766                                 } else {
767                                         $repstr = ' ('.++$repcnt.'x)'
768                                                  if $repcnt;
769                                         print ' ' x $l_in, "$l_name$repstr\n"
770                                                 if $l_name ne '';
771                                         $repstr = '';
772                                         $repcnt = 0;
773                                         $l_in = $in;
774                                         $l_name = $name;
775                                 }
776                                 $in += $tab;
777                         }
778                         if( ! defined $names->{$name} ){
779                                 $names->{$name} = $name;
780                                 $times->{$name} = 0;
781                                 $ctimes->{$name} = 0;
782                                 push( @$idkeys, $name );
783                         }
784                         $calls->{$name}++;
785                         $outer{$name}++;
786                         push @$curdeep_times, { kids => {}, 
787                                                 name => $name, 
788                                                 enter_stamp => $t - $overhead,
789                                               } if $opt_S;
790                         $x = [ $name, $t - $overhead ];
791                         push( @stack, $x );
792
793                         # my children will put their time here
794                         push( @tstack, 0 );
795                 } elsif ($dir ne '-'){
796                     die "Bad profile: $_";
797                 }
798         }
799         if( $opt_t ){
800                 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
801                 print ' ' x $l_in, "$l_name$repstr\n";
802         }
803
804         while (my ($key, $count) = each %outer) {
805             next unless $count;
806             warn "$key has $count unstacked calls in outer\n";
807         }
808
809         if( @stack ){
810                 if( ! $opt_F ){
811                         warn "Garbled profile is missing some exit time stamps:\n";
812                         foreach $x (@stack) {
813                                 print $x->[0],"\n";
814                         }
815                         die "Try rerunning dprofpp with -F.\n";
816                         # I don't want -F to be default behavior--yet
817                         #  9/18/95 dmr
818                 }
819                 else{
820                         warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
821                         foreach $x ( reverse @stack ){
822                                 $name = $x->[0];
823                                 exitstamp( \@stack, \@tstack, 
824                                            $t - $overhead, $times, 
825                                            $ctimes, $name, \$in, $tab, 
826                                            $curdeep_times, \%outer );
827                                 add_to_tree($curdeep_times, $name,
828                                             $t - $overhead)
829                                   if $opt_S;
830                         }
831                 }
832         }
833         if (defined $opt_g) {
834           $runtime = $ctimes->{$opt_g}/$hz;
835           $runtime = 0 unless $runtime > 0;
836         }
837 }
838
839 sub exitstamp {
840         my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
841         my( $x, $c, $z );
842
843         $x = pop( @$stack );
844         if( ! defined $x ){
845                 die "Garbled profile, missing an enter time stamp";
846         }
847         if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
848           if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
849             if ($opt_A) {
850               $name = $x->[0];
851             }
852           } elsif ( $opt_F ) {
853             warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
854             $name = $x->[0];
855           } else {
856             foreach $z (@stack, $x) {
857               print $z->[0],"\n";
858             }
859             die "Garbled profile, unexpected exit time stamp";
860           }
861         }
862         if( $opt_T || $opt_t ){
863                 $$in -= $tab;
864         }
865         # collect childtime
866         $c = pop( @$tstack );
867         # total time this func has been active
868         $z = $t - $x->[1];
869         $ctimes->{$name} += $z
870             unless --$outer->{$name};
871         $times->{$name} += $z - $c;
872         # pass my time to my parent
873         if( @$tstack ){
874                 $c = pop( @$tstack );
875                 push( @$tstack, $c + $z );
876         }
877 }
878
879
880 sub header {
881         my $fh = shift;
882         chop($_ = <$fh>);
883         if( ! /^#fOrTyTwO$/ ){
884                 die "Not a perl profile";
885         }
886         while(<$fh>){
887                 next if /^#/;
888                 last if /^PART/;
889                 eval;
890         }
891         $over_tests = 1 unless $over_tests;
892         $time_precision = length int ($hz - 1); # log ;-)
893 }
894
895
896 # Report avg time-per-function in seconds
897 sub percalc {
898         my( $calls, $times, $persecs, $idkeys ) = @_;
899         my( $x, $t, $n, $key );
900
901         for( $x = 0; $x < @$idkeys; ++$x ){
902                 $key = $idkeys->[$x];
903                 $n = $calls->{$key};
904                 $t = $times->{$key} / $hz;
905                 $persecs->{$key} = $t ? $t / $n : 0;
906         }
907 }
908
909
910 # Runs the given script with the given profiler and the given perl.
911 sub run_profiler {
912         my $script = shift;
913         my $profiler = shift;
914         my $startperl = shift;
915         my @script_parts = split /\s+/, $script;
916
917         system $startperl, "-d:$profiler", @script_parts;
918         if( $? / 256 > 0 ){
919                 my $cmd = join ' ', @script_parts;
920                 die "Failed: $startperl -d:$profiler $cmd: $!";
921         }
922 }
923
924
925 sub by_time { $times->{$b} <=> $times->{$a} }
926 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
927 sub by_calls { $calls->{$b} <=> $calls->{$a} }
928 sub by_alpha { $names->{$a} cmp $names->{$b} }
929 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
930 # Reversed
931 sub rby_time { $times->{$a} <=> $times->{$b} }
932 sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
933 sub rby_calls { $calls->{$a} <=> $calls->{$b} }
934 sub rby_alpha { $names->{$b} cmp $names->{$a} }
935 sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
936
937
938 format CSTAT_top =
939 Total Elapsed Time = @>>>>>>> Seconds
940 (($rrun_rtime - $overhead) / $hz)
941   @>>>>>>>>>> Time = @>>>>>>> Seconds
942 $whichtime, $runtime
943 @<<<<<<<< Times
944 $incl_excl
945 %Time ExclSec CumulS #Calls sec/call Csec/c  Name
946 .
947
948 BEGIN {
949     my $fmt = ' ^>>>   ^>>>> ^>>>>> ^>>>>>   ^>>>>> ^>>>>>  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
950     if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
951     {
952         $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
953     }
954
955     eval "format STAT = \n$fmt" . '
956 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
957 .';
958 }
959 !NO!SUBS!
960
961 close OUT or die "Can't close $file: $!";
962 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
963 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
964