1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5use 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.
16chdir(dirname($0));
17($file = basename($0)) =~ s/\.PL$//i;
18$file .= '.COM' if ($^O eq 'VMS');
19
20my $dprof_pm = File::Spec->catfile(File::Spec->updir, 'ext', 'Devel', 'DProf', 'DProf.pm');
21my $VERSION = 0;
22open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!";
23while(<PM>){
24	if( /^\$Devel::DProf::VERSION\s*=\s*'([\d._]+)'/ ){
25		$VERSION = $1;
26		last;
27	}
28}
29close PM;
30if( $VERSION == 0 ){
31	die "Did not find VERSION in $dprof_pm";
32}
33my $stty = 'undef';
34foreach my $s (qw(/bin/stty /usr/bin/stty)) {
35    if (-x $s) {
36	$stty = qq["$s"];
37	last;
38    }
39}
40open OUT,">$file" or die "Can't create $file: $!";
41
42print "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
47print OUT <<"!GROK!THIS!";
48$Config{'startperl'}
49    eval 'exec perl -S \$0 "\$@"'
50	if 0;
51
52require 5.003;
53
54my \$VERSION = '$VERSION';
55my \$stty    = $stty;
56
57!GROK!THIS!
58
59# In the following, perl variables are not expanded during extraction.
60
61print OUT <<'!NO!SUBS!';
62=head1 NAME
63
64dprofpp - display perl profile data
65
66=head1 SYNOPSIS
67
68dprofpp [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
70dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
71
72dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
73
74dprofpp B<-G> <regexp> [B<-P>] [profile]
75
76dprofpp B<-p script> [B<-Q>] [other opts]
77
78dprofpp B<-V> [profile]
79
80=head1 DESCRIPTION
81
82The I<dprofpp> command interprets profile data produced by a profiler, such
83as the Devel::DProf profiler.  Dprofpp will read the file F<tmon.out> and
84display the 15 subroutines which are using the most time.  By default
85the times for each subroutine are given exclusive of the times of their
86child subroutines.
87
88To profile a Perl script run the perl interpreter with the B<-d> switch.  So
89to profile script F<test.pl> with Devel::DProf use the following:
90
91	$ perl5 -d:DProf test.pl
92
93Then run dprofpp to analyze the profile.  The output of dprofpp depends
94on 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
106The dprofpp tool can also run the profiler before analyzing the profile
107data.  The above two commands can be executed with one dprofpp command.
108
109	$ dprofpp -u -p test.pl
110
111Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
112
113=head1 OUTPUT
114
115Columns are:
116
117=over 4
118
119=item %Time
120
121Percentage of time spent in this routine.
122
123=item #Calls
124
125Number of calls to this routine.
126
127=item sec/call
128
129Average number of seconds per call to this routine.
130
131=item Name
132
133Name of routine.
134
135=item CumulS
136
137Time (in seconds) spent in this routine and routines called from it.
138
139=item ExclSec
140
141Time (in seconds) spent in this routine (not including those called
142from it).
143
144=item Csec/c
145
146Average 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
157Sort alphabetically by subroutine names.
158
159=item B<-d>
160
161Reverse whatever sort is used
162
163=item B<-A>
164
165Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
166Otherwise the time to autoload it is counted as time of the subroutine
167itself (there is no way to separate autoload time from run time).
168
169This is going to be irrelevant with newer Perls.  They will inform
170C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
171so a separate statistics for C<AUTOLOAD> will be collected no matter
172whether this option is set.
173
174=item B<-R>
175
176Count 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
184Force the generation of fake exit timestamps if dprofpp reports that the
185profile is garbled.  This is only useful if dprofpp determines that the
186profile is garbled due to missing exit timestamps.  You're on your own if
187you do this.  Consult the BUGS section.
188
189=item B<-I>
190
191Display all subroutine times inclusive of child subroutine times.
192
193=item B<-l>
194
195Sort by number of calls to the subroutines.  This may help identify
196candidates for inlining.
197
198=item B<-O cnt>
199
200Show only I<cnt> subroutines.  The default is 15.
201
202=item B<-p script>
203
204Tells dprofpp that it should profile the given script and then interpret its
205profile data.  See B<-Q>.
206
207=item B<-Q>
208
209Used with B<-p> to tell dprofpp to quit after profiling the script, without
210interpreting the data.
211
212=item B<-q>
213
214Do not display column headers.
215
216=item B<-r>
217
218Display elapsed real times rather than user+system times.
219
220=item B<-s>
221
222Display system times rather than user+system times.
223
224=item B<-T>
225
226Display subroutine call tree to stdout.  Subroutine statistics are
227not displayed.
228
229=item B<-t>
230
231Display subroutine call tree to stdout.  Subroutine statistics are not
232displayed.  When a function is called multiple consecutive times at the same
233calling level then it is displayed once with a repeat count.
234
235=item B<-S>
236
237Display I<merged> subroutine call tree to stdout.  Statistics are
238displayed for each branch of the tree.
239
240When a function is called multiple (I<not necessarily consecutive>)
241times in the same branch then all these calls go into one branch of
242the next level.  A repeat count is output together with combined
243inclusive, exclusive and kids time.
244
245Branches are sorted with regard to inclusive time.
246
247=item B<-U>
248
249Do not sort.  Display in the order found in the raw profile.
250
251=item B<-u>
252
253Display user times rather than user+system times.
254
255=item B<-V>
256
257Print dprofpp's version number and exit.  If a raw profile is found then its
258XS_VERSION variable will be displayed, too.
259
260=item B<-v>
261
262Sort by average time spent in subroutines during each call.  This may help
263identify candidates for inlining.
264
265=item B<-z>
266
267(default) Sort by amount of user+system time used.  The first few lines
268should show you which subroutines are using the most time.
269
270=item B<-g> C<subroutine>
271
272Ignore subroutines except C<subroutine> and whatever is called from it.
273
274=item B<-G> <regexp>
275
276Aggregate "Group" all calls matching the pattern together.
277For example this can be used to group all calls of a set of packages
278
279  -G "(package1::)|(package2::)|(package3::)"
280
281or to group subroutines by name:
282
283  -G "getNum"
284
285=item B<-P>
286
287Used with -G to aggregate "Pull" together all calls that did not match -G.
288
289=item B<-f> <regexp>
290
291Filter all calls matching the pattern.
292
293=item B<-h>
294
295Display brief help and exit.
296
297=item B<-H>
298
299Display long help and exit.
300
301=back
302
303=head1 ENVIRONMENT
304
305The environment variable B<DPROFPP_OPTS> can be set to a string containing
306options for dprofpp.  You might use this if you prefer B<-I> over B<-E> or
307if you want B<-F> on all the time.
308
309This was added fairly lazily, so there are some undesirable side effects.
310Options on the commandline should override options in DPROFPP_OPTS--but
311don't count on that in this version.
312
313=head1 BUGS
314
315Applications which call _exit() or exec() from within a subroutine
316will leave an incomplete profile.  See the B<-F> option.
317
318Any bugs in Devel::DProf, or any profiler generating the profile data, could
319be visible here.  See L<Devel::DProf/BUGS>.
320
321Mail bug reports and feature requests to the perl5-porters mailing list at
322F<E<lt>perl5-porters@perl.orgE<gt>>.  Bug reports should include the
323output 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
332L<perl>, L<Devel::DProf>, times(2)
333
334=cut
335
336sub shortusage {
337    print <<'EOF';
338dprofpp [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 mathcing the pattern.
345    -G          Group all calls matching the pattern together.
346    -g subr     Count only those 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 the dprofpp should quit
355                after profiling the script, without interpreting the data.
356    -q          Do not print column headers.
357    -R          Count anonyms 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)
368EOF
369}
370
371use Getopt::Std 'getopts';
372use Config '%Config';
373
374Setup: {
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
447Main: {
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
516sub 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#
563sub 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
583sub 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
601sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
602		   or $a cmp $b }
603
604sub 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.
628sub 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
657sub 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
673sub 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
693sub 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
862sub 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
903sub 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
920sub 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.
934sub 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
948sub by_time { $times->{$b} <=> $times->{$a} }
949sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
950sub by_calls { $calls->{$b} <=> $calls->{$a} }
951sub by_alpha { $names->{$a} cmp $names->{$b} }
952sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
953# Reversed
954sub rby_time { $times->{$a} <=> $times->{$b} }
955sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
956sub rby_calls { $calls->{$a} <=> $calls->{$b} }
957sub rby_alpha { $names->{$b} cmp $names->{$a} }
958sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
959
960
961format CSTAT_top =
962Total 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
971BEGIN {
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
984close OUT or die "Can't close $file: $!";
985chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
986exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
987
988