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