Installer: Early check whether the installation directory is writable
[msysgit.git] / bin / dprofpp
blob148c50c12e1955baf8676db09626ccf169981f6e
1 #!/usr/bin/perl
2 eval 'exec perl -S $0 "$@"'
3 if 0;
5 require 5.003;
7 my $VERSION = '20050603.00';
8 my $stty = undef;
10 =head1 NAME
12 dprofpp - display perl profile data
14 =head1 SYNOPSIS
16 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]
18 dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
20 dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
22 dprofpp B<-G> <regexp> [B<-P>] [profile]
24 dprofpp B<-p script> [B<-Q>] [other opts]
26 dprofpp B<-V> [profile]
28 =head1 DESCRIPTION
30 The I<dprofpp> command interprets profile data produced by a profiler, such
31 as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and
32 display the 15 subroutines which are using the most time. By default
33 the times for each subroutine are given exclusive of the times of their
34 child subroutines.
36 To profile a Perl script run the perl interpreter with the B<-d> switch. So
37 to profile script F<test.pl> with Devel::DProf use the following:
39 $ perl5 -d:DProf test.pl
41 Then run dprofpp to analyze the profile. The output of dprofpp depends
42 on the flags to the program and the version of Perl you're using.
44 $ dprofpp -u
45 Total Elapsed Time = 1.67 Seconds
46 User Time = 0.61 Seconds
47 Exclusive Times
48 %Time Seconds #Calls sec/call Name
49 52.4 0.320 2 0.1600 main::foo
50 45.9 0.280 200 0.0014 main::bar
51 0.00 0.000 1 0.0000 DynaLoader::import
52 0.00 0.000 1 0.0000 main::baz
54 The dprofpp tool can also run the profiler before analyzing the profile
55 data. The above two commands can be executed with one dprofpp command.
57 $ dprofpp -u -p test.pl
59 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
61 =head1 OUTPUT
63 Columns are:
65 =over 4
67 =item %Time
69 Percentage of time spent in this routine.
71 =item #Calls
73 Number of calls to this routine.
75 =item sec/call
77 Average number of seconds per call to this routine.
79 =item Name
81 Name of routine.
83 =item CumulS
85 Time (in seconds) spent in this routine and routines called from it.
87 =item ExclSec
89 Time (in seconds) spent in this routine (not including those called
90 from it).
92 =item Csec/c
94 Average time (in seconds) spent in each call of this routine
95 (including those called from it).
97 =back
99 =head1 OPTIONS
101 =over 5
103 =item B<-a>
105 Sort alphabetically by subroutine names.
107 =item B<-d>
109 Reverse whatever sort is used
111 =item B<-A>
113 Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
114 Otherwise the time to autoload it is counted as time of the subroutine
115 itself (there is no way to separate autoload time from run time).
117 This is going to be irrelevant with newer Perls. They will inform
118 C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
119 so a separate statistics for C<AUTOLOAD> will be collected no matter
120 whether this option is set.
122 =item B<-R>
124 Count anonymous subroutines defined in the same package separately.
126 =item B<-E>
128 (default) Display all subroutine times exclusive of child subroutine times.
130 =item B<-F>
132 Force the generation of fake exit timestamps if dprofpp reports that the
133 profile is garbled. This is only useful if dprofpp determines that the
134 profile is garbled due to missing exit timestamps. You're on your own if
135 you do this. Consult the BUGS section.
137 =item B<-I>
139 Display all subroutine times inclusive of child subroutine times.
141 =item B<-l>
143 Sort by number of calls to the subroutines. This may help identify
144 candidates for inlining.
146 =item B<-O cnt>
148 Show only I<cnt> subroutines. The default is 15.
150 =item B<-p script>
152 Tells dprofpp that it should profile the given script and then interpret its
153 profile data. See B<-Q>.
155 =item B<-Q>
157 Used with B<-p> to tell dprofpp to quit after profiling the script, without
158 interpreting the data.
160 =item B<-q>
162 Do not display column headers.
164 =item B<-r>
166 Display elapsed real times rather than user+system times.
168 =item B<-s>
170 Display system times rather than user+system times.
172 =item B<-T>
174 Display subroutine call tree to stdout. Subroutine statistics are
175 not displayed.
177 =item B<-t>
179 Display subroutine call tree to stdout. Subroutine statistics are not
180 displayed. When a function is called multiple consecutive times at the same
181 calling level then it is displayed once with a repeat count.
183 =item B<-S>
185 Display I<merged> subroutine call tree to stdout. Statistics are
186 displayed for each branch of the tree.
188 When a function is called multiple (I<not necessarily consecutive>)
189 times in the same branch then all these calls go into one branch of
190 the next level. A repeat count is output together with combined
191 inclusive, exclusive and kids time.
193 Branches are sorted with regard to inclusive time.
195 =item B<-U>
197 Do not sort. Display in the order found in the raw profile.
199 =item B<-u>
201 Display user times rather than user+system times.
203 =item B<-V>
205 Print dprofpp's version number and exit. If a raw profile is found then its
206 XS_VERSION variable will be displayed, too.
208 =item B<-v>
210 Sort by average time spent in subroutines during each call. This may help
211 identify candidates for inlining.
213 =item B<-z>
215 (default) Sort by amount of user+system time used. The first few lines
216 should show you which subroutines are using the most time.
218 =item B<-g> C<subroutine>
220 Ignore subroutines except C<subroutine> and whatever is called from it.
222 =item B<-G> <regexp>
224 Aggregate "Group" all calls matching the pattern together.
225 For example this can be used to group all calls of a set of packages
227 -G "(package1::)|(package2::)|(package3::)"
229 or to group subroutines by name:
231 -G "getNum"
233 =item B<-P>
235 Used with -G to aggregate "Pull" together all calls that did not match -G.
237 =item B<-f> <regexp>
239 Filter all calls matching the pattern.
241 =item B<-h>
243 Display brief help and exit.
245 =item B<-H>
247 Display long help and exit.
249 =back
251 =head1 ENVIRONMENT
253 The environment variable B<DPROFPP_OPTS> can be set to a string containing
254 options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
255 if you want B<-F> on all the time.
257 This was added fairly lazily, so there are some undesirable side effects.
258 Options on the commandline should override options in DPROFPP_OPTS--but
259 don't count on that in this version.
261 =head1 BUGS
263 Applications which call _exit() or exec() from within a subroutine
264 will leave an incomplete profile. See the B<-F> option.
266 Any bugs in Devel::DProf, or any profiler generating the profile data, could
267 be visible here. See L<Devel::DProf/BUGS>.
269 Mail bug reports and feature requests to the perl5-porters mailing list at
270 F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
271 output of the B<-V> option.
273 =head1 FILES
275 dprofpp - profile processor
276 tmon.out - raw profile
278 =head1 SEE ALSO
280 L<perl>, L<Devel::DProf>, times(2)
282 =cut
284 sub shortusage {
285 print <<'EOF';
286 dprofpp [options] [profile]
288 -A Count autoloaded to *AUTOLOAD
289 -a Sort by alphabetic name of subroutines.
290 -d Reverse sort
291 -E Sub times are reported exclusive of child times. (default)
292 -f Filter all calls mathcing the pattern.
293 -G Group all calls matching the pattern together.
294 -g subr Count only those who are SUBR or called from SUBR
295 -H Display long manual page.
296 -h Display this short usage message.
297 -I Sub times are reported inclusive of child times.
298 -l Sort by number of calls to subroutines.
299 -O cnt Specifies maximum number of subroutines to display.
300 -P Used with -G to pull all other calls together.
301 -p script Specifies name of script to be profiled.
302 -Q Used with -p to indicate the dprofpp should quit
303 after profiling the script, without interpreting the data.
304 -q Do not print column headers.
305 -R Count anonyms separately even if from the same package
306 -r Use real elapsed time rather than user+system time.
307 -S Create statistics for all the depths
308 -s Use system time rather than user+system time.
309 -T Show call tree.
310 -t Show call tree, compressed.
311 -U Do not sort subroutines.
312 -u Use user time rather than user+system time.
313 -V Print dprofpp's version.
314 -v Sort by average amount of time spent in subroutines.
315 -z Sort by user+system time spent in subroutines. (default)
319 use Getopt::Std 'getopts';
320 use Config '%Config';
322 Setup: {
323 my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
325 $Monfile = 'tmon.out';
326 if( exists $ENV{DPROFPP_OPTS} ){
327 my @tmpargv = @ARGV;
328 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
329 getopts( $options );
330 if( @ARGV ){
331 # there was a filename.
332 $Monfile = shift;
334 @ARGV = @tmpargv;
337 getopts( $options ) or die "Try 'dprofpp -h' for help.\n";
338 if( @ARGV ){
339 # there was a filename, it overrides any earlier name.
340 $Monfile = shift;
343 if ( defined $opt_h ) {
344 shortusage();
345 exit;
347 if ( defined $opt_H ) {
348 require Pod::Usage;
349 Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
350 exit;
353 if( defined $opt_V ){
354 my $fh = 'main::fh';
355 print "$0 version: $VERSION\n";
356 open( $fh, "<$Monfile" ) && do {
357 local $XS_VERSION = 'early';
358 header($fh);
359 close( $fh );
360 print "XS_VERSION: $XS_VERSION\n";
362 exit(0);
364 $cnt = $opt_O || 15;
365 $sort = 'by_time';
366 $sort = 'by_ctime' if defined $opt_I;
367 $sort = 'by_calls' if defined $opt_l;
368 $sort = 'by_alpha' if defined $opt_a;
369 $sort = 'by_avgcpu' if defined $opt_v;
371 if(defined $opt_d){
372 $sort = "r".$sort;
374 $incl_excl = 'Exclusive';
375 $incl_excl = 'Inclusive' if defined $opt_I;
376 $whichtime = 'User+System';
377 $whichtime = 'System' if defined $opt_s;
378 $whichtime = 'Real' if defined $opt_r;
379 $whichtime = 'User' if defined $opt_u;
381 if( defined $opt_p ){
382 my $prof = 'DProf';
383 my $startperl = $Config{'startperl'};
385 $startperl =~ s/^#!//; # remove shebang
386 run_profiler( $opt_p, $prof, $startperl );
387 $Monfile = 'tmon.out'; # because that's where it is
388 exit(0) if defined $opt_Q;
390 elsif( defined $opt_Q ){
391 die "-Q is meaningful only when used with -p\n";
395 Main: {
396 my $monout = $Monfile;
397 my $fh = 'main::fh';
398 local $names = {};
399 local $times = {}; # times in hz
400 local $ctimes = {}; # Cumulative times in hz
401 local $calls = {};
402 local $persecs = {}; # times in seconds
403 local $idkeys = [];
404 local $runtime; # runtime in seconds
405 my @a = ();
406 my $a;
407 local $rrun_utime = 0; # user time in hz
408 local $rrun_stime = 0; # system time in hz
409 local $rrun_rtime = 0; # elapsed run time in hz
410 local $rrun_ustime = 0; # user+system time in hz
411 local $hz = 0;
412 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
413 local $time_precision = 2;
414 local $overhead = 0;
416 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
418 header($fh);
420 $rrun_ustime = $rrun_utime + $rrun_stime;
422 $~ = 'STAT';
423 if( ! $opt_q ){
424 $^ = 'CSTAT_top';
427 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
429 #filter calls
430 if( $opt_f ){
431 for(my $i = 0;$i < @$idkeys - 2;){
432 $key = $$idkeys[$i];
433 if($key =~ /$opt_f/){
434 splice(@$idkeys, $i, 1);
435 $runtime -= $$times{$key};
436 next;
438 $i++;
442 if( $opt_G ){
443 group($names, $calls, $times, $ctimes, $idkeys );
446 settime( \$runtime, $hz ) unless $opt_g;
448 exit(0) if $opt_T || $opt_t;
450 if( $opt_v ){
451 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
453 if( ! $opt_U ){
454 @a = sort $sort @$idkeys;
455 $a = \@a;
457 else {
458 $a = $idkeys;
460 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
461 $deep_times);
464 sub group{
465 my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
466 print "Option G Grouping: [$opt_G]\n";
467 # create entries to store grouping
468 $$names{$opt_G} = $opt_G;
469 $$calls{$opt_G} = 0;
470 $$times{$opt_G} = 0;
471 $$ctimes{$opt_G} = 0;
472 $$idkeys[@$idkeys] = $opt_G;
473 # Sum calls for the grouping
475 my $other = "other";
476 if($opt_P){
477 $$names{$other} = $other;
478 $$calls{$other} = 0;
479 $$times{$other} = 0;
480 $$ctimes{$other} = 0;
481 $$idkeys[@$idkeys] = $other;
484 for(my $i = 0;$i < @$idkeys - 2;){
485 $key = $$idkeys[$i];
486 if($key =~ /$opt_G/){
487 $$calls{$opt_G} += $$calls{$key};
488 $$times{$opt_G} += $$times{$key};
489 $$ctimes{$opt_G} += $$ctimes{$key};
490 splice(@$idkeys, $i, 1);
491 next;
492 }else{
493 if($opt_P){
494 $$calls{$other} += $$calls{$key};
495 $$times{$other} += $$times{$key};
496 $$ctimes{$other} += $$ctimes{$key};
497 splice(@$idkeys, $i, 1);
498 next;
501 $i++;
503 print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
504 "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
505 "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
508 # Sets $runtime to user, system, real, or user+system time. The
509 # result is given in seconds.
511 sub settime {
512 my( $runtime, $hz ) = @_;
514 $hz ||= 1;
516 if( $opt_r ){
517 $$runtime = ($rrun_rtime - $overhead)/$hz;
519 elsif( $opt_s ){
520 $$runtime = ($rrun_stime - $overhead)/$hz;
522 elsif( $opt_u ){
523 $$runtime = ($rrun_utime - $overhead)/$hz;
525 else{
526 $$runtime = ($rrun_ustime - $overhead)/$hz;
528 $$runtime = 0 unless $$runtime > 0;
531 sub exclusives_in_tree {
532 my( $deep_times ) = @_;
533 my $kids_time = 0;
534 my $kid;
535 # When summing, take into account non-rounded-up kids time.
536 for $kid (keys %{$deep_times->{kids}}) {
537 $kids_time += $deep_times->{kids}{$kid}{incl_time};
539 $kids_time = 0 unless $kids_time >= 0;
540 $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
541 $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
542 for $kid (keys %{$deep_times->{kids}}) {
543 exclusives_in_tree($deep_times->{kids}{$kid});
545 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
546 $deep_times->{kids_time} = $kids_time;
549 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
550 or $a cmp $b }
552 sub display_tree {
553 my( $deep_times, $name, $level ) = @_;
554 exclusives_in_tree($deep_times);
556 my $kid;
558 my $time;
559 if (%{$deep_times->{kids}}) {
560 $time = sprintf '%.*fs = (%.*f + %.*f)',
561 $time_precision, $deep_times->{incl_time}/$hz,
562 $time_precision, $deep_times->{excl_time}/$hz,
563 $time_precision, $deep_times->{kids_time}/$hz;
564 } else {
565 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
567 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
568 if $deep_times->{count};
570 for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
571 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
575 # Report the times in seconds.
576 sub display {
577 my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
578 $idkeys, $deep_times ) = @_;
579 my( $x, $key, $s, $cs );
580 #format: $ncalls, $name, $secs, $percall, $pcnt
582 if ($opt_S) {
583 display_tree( $deep_times, 'toplevel', -1 )
584 } else {
585 for( $x = 0; $x < @$idkeys; ++$x ){
586 $key = $idkeys->[$x];
587 $ncalls = $calls->{$key};
588 $name = $names->{$key};
589 $s = $times->{$key}/$hz;
590 $secs = sprintf("%.3f", $s );
591 $cs = $ctimes->{$key}/$hz;
592 $csecs = sprintf("%.3f", $cs );
593 $percall = sprintf("%.4f", $s/$ncalls );
594 $cpercall = sprintf("%.4f", $cs/$ncalls );
595 $pcnt = sprintf("%.2f",
596 $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
597 write;
598 $pcnt = $secs = $ncalls = $percall = "";
599 write while( length $name );
600 last unless --$cnt;
605 sub move_keys {
606 my ($source, $dest) = @_;
608 for my $kid_name (keys %$source) {
609 my $source_kid = delete $source->{$kid_name};
611 if (my $dest_kid = $dest->{$kid_name}) {
612 $dest_kid->{count} += $source_kid->{count};
613 $dest_kid->{incl_time} += $source_kid->{incl_time};
614 move_keys($source_kid->{kids},$dest_kid->{kids});
615 } else {
616 $dest->{$kid_name} = $source_kid;
621 sub add_to_tree {
622 my ($curdeep_times, $name, $t) = @_;
623 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
624 $name = $curdeep_times->[-1]{name};
626 die "Shorted?!" unless @$curdeep_times >= 2;
627 my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
628 count => 0,
629 kids => {},
630 incl_time => 0,
632 # Now transfer to the new node (could not do earlier, since name can change)
633 $entry->{count}++;
634 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
635 # Merge the kids?
636 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
637 pop @$curdeep_times;
641 sub parsestack {
642 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
643 my( $dir, $name );
644 my( $t, $syst, $realt, $usert );
645 my( $x, $z, $c, $id, $pack );
646 my @stack = ();
647 my @tstack = ();
648 my %outer;
649 my $tab = 3;
650 my $in = 0;
652 # remember last call depth and function name
653 my $l_in = $in;
654 my $l_name = '';
655 my $repcnt = 0;
656 my $repstr = '';
657 my $dprof_stamp;
658 my %cv_hash;
659 my $in_level = not defined $opt_g; # Level deep in report grouping
660 my $curdeep_times = [$deep_times];
662 my $over_per_call;
663 if ( $opt_u ) { $over_per_call = $over_utime }
664 elsif( $opt_s ) { $over_per_call = $over_stime }
665 elsif( $opt_r ) { $over_per_call = $over_rtime }
666 else { $over_per_call = $over_utime + $over_stime }
667 $over_per_call /= 2*$over_tests; # distribute over entry and exit
669 while(<$fh>){
670 next if /^#/;
671 last if /^PART/;
673 chop;
674 if (/^&/) {
675 ($dir, $id, $pack, $name) = split;
676 if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
677 $name .= "($id)";
679 $cv_hash{$id} = "$pack\::$name";
680 next;
682 ($dir, $usert, $syst, $realt, $name) = split;
684 my $ot = $t;
685 if ( $dir eq '/' ) {
686 $syst = $stack[-1][0] if scalar @stack;
687 $usert = '&';
688 $dir = '-';
689 #warn("Inserted exit for $stack[-1][0].\n")
691 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
692 if ( $opt_u ) { $t = $usert }
693 elsif( $opt_s ) { $t = $syst }
694 elsif( $opt_r ) { $t = $realt }
695 else { $t = $usert + $syst }
696 $t += $ot, next if $dir eq '@'; # Increments there
697 } else {
698 # "- id" or "- & name"
699 $name = defined $syst ? $syst : $cv_hash{$usert};
702 next unless $in_level or $name eq $opt_g;
703 if ( $dir eq '-' or $dir eq '*' ) {
704 my $ename = $dir eq '*' ? $stack[-1][0] : $name;
705 $overhead += $over_per_call;
706 if ($name eq "Devel::DProf::write") {
707 $overhead += $t - $dprof_stamp;
708 next;
709 } elsif (defined $opt_g and $ename eq $opt_g) {
710 $in_level--;
712 add_to_tree($curdeep_times, $ename,
713 $t - $overhead) if $opt_S;
714 exitstamp( \@stack, \@tstack,
715 $t - $overhead,
716 $times, $ctimes, $name, \$in, $tab,
717 $curdeep_times, \%outer );
719 next unless $in_level or $name eq $opt_g;
720 if( $dir eq '+' or $dir eq '*' ){
721 if ($name eq "Devel::DProf::write") {
722 $dprof_stamp = $t;
723 next;
724 } elsif (defined $opt_g and $name eq $opt_g) {
725 $in_level++;
727 $overhead += $over_per_call;
728 if( $opt_T ){
729 print ' ' x $in, "$name\n";
730 $in += $tab;
732 elsif( $opt_t ){
733 # suppress output on same function if the
734 # same calling level is called.
735 if ($l_in == $in and $l_name eq $name) {
736 $repcnt++;
737 } else {
738 $repstr = ' ('.++$repcnt.'x)'
739 if $repcnt;
740 print ' ' x $l_in, "$l_name$repstr\n"
741 if $l_name ne '';
742 $repstr = '';
743 $repcnt = 0;
744 $l_in = $in;
745 $l_name = $name;
747 $in += $tab;
749 if( ! defined $names->{$name} ){
750 $names->{$name} = $name;
751 $times->{$name} = 0;
752 $ctimes->{$name} = 0;
753 push( @$idkeys, $name );
755 $calls->{$name}++;
756 $outer{$name}++;
757 push @$curdeep_times, { kids => {},
758 name => $name,
759 enter_stamp => $t - $overhead,
760 } if $opt_S;
761 $x = [ $name, $t - $overhead ];
762 push( @stack, $x );
764 # my children will put their time here
765 push( @tstack, 0 );
766 } elsif ($dir ne '-'){
767 die "Bad profile: $_";
770 if( $opt_t ){
771 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
772 print ' ' x $l_in, "$l_name$repstr\n";
775 while (my ($key, $count) = each %outer) {
776 next unless $count;
777 warn "$key has $count unstacked calls in outer\n";
780 if( @stack ){
781 if( ! $opt_F ){
782 warn "Garbled profile is missing some exit time stamps:\n";
783 foreach $x (@stack) {
784 print $x->[0],"\n";
786 die "Try rerunning dprofpp with -F.\n";
787 # I don't want -F to be default behavior--yet
788 # 9/18/95 dmr
790 else{
791 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
792 foreach $x ( reverse @stack ){
793 $name = $x->[0];
794 exitstamp( \@stack, \@tstack,
795 $t - $overhead, $times,
796 $ctimes, $name, \$in, $tab,
797 $curdeep_times, \%outer );
798 add_to_tree($curdeep_times, $name,
799 $t - $overhead)
800 if $opt_S;
804 if (defined $opt_g) {
805 $runtime = $ctimes->{$opt_g}/$hz;
806 $runtime = 0 unless $runtime > 0;
810 sub exitstamp {
811 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
812 my( $x, $c, $z );
814 $x = pop( @$stack );
815 if( ! defined $x ){
816 die "Garbled profile, missing an enter time stamp";
818 if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
819 if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
820 if ($opt_A) {
821 $name = $x->[0];
823 } elsif ( $opt_F ) {
824 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
825 $name = $x->[0];
826 } else {
827 foreach $z (@stack, $x) {
828 print $z->[0],"\n";
830 die "Garbled profile, unexpected exit time stamp";
833 if( $opt_T || $opt_t ){
834 $$in -= $tab;
836 # collect childtime
837 $c = pop( @$tstack );
838 # total time this func has been active
839 $z = $t - $x->[1];
840 $ctimes->{$name} += $z
841 unless --$outer->{$name};
842 $times->{$name} += $z - $c;
843 # pass my time to my parent
844 if( @$tstack ){
845 $c = pop( @$tstack );
846 push( @$tstack, $c + $z );
851 sub header {
852 my $fh = shift;
853 chop($_ = <$fh>);
854 if( ! /^#fOrTyTwO$/ ){
855 die "Not a perl profile";
857 while(<$fh>){
858 next if /^#/;
859 last if /^PART/;
860 eval;
862 $over_tests = 1 unless $over_tests;
863 $time_precision = length int ($hz - 1); # log ;-)
867 # Report avg time-per-function in seconds
868 sub percalc {
869 my( $calls, $times, $persecs, $idkeys ) = @_;
870 my( $x, $t, $n, $key );
872 for( $x = 0; $x < @$idkeys; ++$x ){
873 $key = $idkeys->[$x];
874 $n = $calls->{$key};
875 $t = $times->{$key} / $hz;
876 $persecs->{$key} = $t ? $t / $n : 0;
881 # Runs the given script with the given profiler and the given perl.
882 sub run_profiler {
883 my $script = shift;
884 my $profiler = shift;
885 my $startperl = shift;
886 my @script_parts = split /\s+/, $script;
888 system $startperl, "-d:$profiler", @script_parts;
889 if( $? / 256 > 0 ){
890 my $cmd = join ' ', @script_parts;
891 die "Failed: $startperl -d:$profiler $cmd: $!";
896 sub by_time { $times->{$b} <=> $times->{$a} }
897 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
898 sub by_calls { $calls->{$b} <=> $calls->{$a} }
899 sub by_alpha { $names->{$a} cmp $names->{$b} }
900 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
901 # Reversed
902 sub rby_time { $times->{$a} <=> $times->{$b} }
903 sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
904 sub rby_calls { $calls->{$a} <=> $calls->{$b} }
905 sub rby_alpha { $names->{$b} cmp $names->{$a} }
906 sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
909 format CSTAT_top =
910 Total Elapsed Time = @>>>>>>> Seconds
911 (($rrun_rtime - $overhead) / $hz)
912 @>>>>>>>>>> Time = @>>>>>>> Seconds
913 $whichtime, $runtime
914 @<<<<<<<< Times
915 $incl_excl
916 %Time ExclSec CumulS #Calls sec/call Csec/c Name
919 BEGIN {
920 my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
921 if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
923 $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
926 eval "format STAT = \n$fmt" . '
927 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name