dprofpp enhanced

--- /tmp/dprofpp	2008-08-24 13:35:33.000000000 +0200
+++ /tmp/dprofpp-5.10.1	2008-08-24 13:43:47.242108430 +0200
@@ -59,17 +59,9 @@
 # In the following, perl variables are not expanded during extraction.
 
 print OUT <<'!NO!SUBS!';
-=head1 NAME
-
-dprofpp - display perl profile data
-
-=head1 SYNOPSIS
-
 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]
   
-dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
-
-dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+dprofpp B<-T|-t> [B<-F>] [B<-c regexp>] [B<-g subroutine>] [B<-i regexp>] [B<-w num>] [profile]
 
 dprofpp B<-G> <regexp> [B<-P>] [profile]
  
@@ -221,6 +213,18 @@
 
 Display system times rather than user+system times.
 
+=item B<-S>
+
+Display I<merged> subroutine call tree to stdout.  Statistics are
+displayed for each branch of the tree.
+
+When a function is called multiple (I<not necessarily consecutive>)
+times in the same branch then all these calls go into one branch of
+the next level.  A repeat count is output together with combined
+inclusive, exclusive and kids time.
+
+Branches are sorted with regard to inclusive time.
+
 =item B<-T>
 
 Display subroutine call tree to stdout.  Subroutine statistics are
@@ -232,17 +236,25 @@
 displayed.  When a function is called multiple consecutive times at the same
 calling level then it is displayed once with a repeat count.
 
-=item B<-S>
+=item B<-c regexp>
 
-Display I<merged> subroutine call tree to stdout.  Statistics are
-displayed for each branch of the tree.  
+Cut call tree display under any node matching regexp, such that the subtree
+root appears as a leaf.
 
-When a function is called multiple (I<not necessarily consecutive>)
-times in the same branch then all these calls go into one branch of
-the next level.  A repeat count is output together with combined
-inclusive, exclusive and kids time.
+=item B<-i regexp>
 
-Branches are sorted with regard to inclusive time.
+Ignore any subtree who's root matches regexp.
+
+=item B<-o>
+
+Changes the format of -t, -T or -S to that of Emacs' M-x outline-mode.  This
+allows highlighting the first 9 tree levels in different colors, navigating
+along the structure of the tree and hiding parts of it.
+
+=item B<-w number>
+
+Gives the indentation width for call trees.  A value of 0 is convenient for
+piping the output to C<sort -u>.
 
 =item B<-U>
 
@@ -339,16 +351,19 @@
 
     -A          Count autoloaded to *AUTOLOAD
     -a          Sort by alphabetic name of subroutines.
+    -c regexp   Cut display under matching functions (-T/-t)
     -d          Reverse sort
     -E          Sub times are reported exclusive of child times. (default)
     -f          Filter all calls mathcing the pattern.
     -G          Group all calls matching the pattern together.
-    -g subr     Count only those who are SUBR or called from SUBR
+    -g subr     Count or show only those who are SUBR or called from SUBR
     -H          Display long manual page.
     -h          Display this short usage message.
     -I          Sub times are reported inclusive of child times.
+    -i regexp   Ignore matching functions and all below them (-T/-t).
     -l          Sort by number of calls to subroutines.
     -O cnt      Specifies maximum number of subroutines to display.
+    -o          Alternate tree format for Emacs M-x outline-mode.
     -P          Used with -G to pull all other calls together.
     -p script   Specifies name of script to be profiled.
     -Q          Used with -p to indicate the dprofpp should quit
@@ -364,6 +379,7 @@
     -u          Use user time rather than user+system time.
     -V          Print dprofpp's version.
     -v          Sort by average amount of time spent in subroutines.
+    -w num      Tab width for -T/-t, defaults to 3.
     -z          Sort by user+system time spent in subroutines. (default)
 EOF
 }
@@ -372,7 +388,7 @@
 use Config '%Config';
 
 Setup: {
-	my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
+	my $options = 'O:g:G:Pf:dlzaAvuTtc:i:oqrRsUFEIp:QVShHw:';
 
 	$Monfile = 'tmon.out';
 	if( exists $ENV{DPROFPP_OPTS} ){
@@ -482,7 +498,7 @@
 	if( $opt_f ){
 		for(my $i = 0;$i < @$idkeys - 2;){
 			$key = $$idkeys[$i];
-			if($key =~ /$opt_f/){
+			if($key =~ /$opt_f/o){
 				splice(@$idkeys, $i, 1);
 				$runtime -= $$times{$key};
 				next;
@@ -616,7 +632,8 @@
   } else {
     $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
   }
-  print ' ' x (2*$level), "$name x $deep_times->{count}  \t${time}s\n"
+  print $opt_o ? (%{$deep_times->{kids}} ? '*' x ($level+1) . ' ' : ' ' x ($level+2)) : ' ' x ($opt_w*$level) ,
+    "$name x $deep_times->{count}  \t${time}s\n"
     if $deep_times->{count};
 
   for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
@@ -689,6 +706,20 @@
   pop @$curdeep_times;
 }
 
+my $prune;
+sub show {
+	my( $in, $name ) = @_;
+	return if defined $prune && $in > $prune;
+	if( $opt_c && $name =~ /$opt_c/o ) {
+		$prune = $in;
+	} elsif( $opt_i && $name =~ /$opt_i/o ) {
+		$prune = $in;
+		return;
+	} else {
+		undef $prune;
+	}
+	1;
+}
 
 sub parsestack {
 	my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
@@ -698,12 +729,17 @@
 	my @stack = ();
 	my @tstack = ();
 	my %outer;
-	my $tab = 3;
 	my $in = 0;
+	if( $opt_o ) {
+	    $in = $opt_w = 1;
+	} elsif( !defined $opt_w ) {
+	    $opt_w ||= 3;
+	}
 
 	# remember last call depth and function name
-	my $l_in = $in;
-	my $l_name = '';
+	my $l_in = $in - 1;
+	my @l_names;
+	my $desc;
 	my $repcnt = 0;
 	my $repstr = '';
 	my $dprof_stamp;
@@ -765,7 +801,7 @@
 				    $t - $overhead) if $opt_S;
 			exitstamp( \@stack, \@tstack,
 				   $t - $overhead,
-				   $times, $ctimes, $name, \$in, $tab,
+				   $times, $ctimes, $name, \$in,
 				   $curdeep_times, \%outer );
 		} 
 		next unless $in_level or $name eq $opt_g;
@@ -777,26 +813,55 @@
 			  $in_level++;
 		  	}
 			$overhead += $over_per_call;
-			if( $opt_T ){
+			if( $opt_T || $opt_t ) {
+			    if( show $in, $name ) {
+					if ( $opt_T ) {
+						if ( !$opt_o ) {
 				print ' ' x $in, "$name\n";
-				$in += $tab;
+						} elsif ( $l_in != $in ) {
+							print $l_in > $in && $desc ? ' ' x ($l_in+1) : '*' x $l_in . ' ',
+								"$_\n"
+								for @l_names;
+							$desc = $l_in < $in;
+							$l_in = $in;
+							@l_names = $name;
+						} else {
+							push @l_names, $name;
 			}
-			elsif( $opt_t ){
+					} else {
 				# suppress output on same function if the
 				# same calling level is called.
-				if ($l_in == $in and $l_name eq $name) {
+						if ( $l_in == $in && @l_names && $l_names[-1] eq $name ) {
 					$repcnt++;
 				} else {
 					$repstr = ' ('.++$repcnt.'x)'
 						 if $repcnt;
-					print ' ' x $l_in, "$l_name$repstr\n"
-						if $l_name ne '';
+							if ( !$opt_o ) {
+								print ' ' x $l_in, "@l_names$repstr\n"
+									if @l_names;
+								@l_names = $name;
+							} elsif ( @l_names ) {
+								$l_names[-1] .= $repstr
+									if $repcnt;
+								if ( $l_in != $in ) {
+									print $l_in > $in && $desc ? ' ' x ($l_in+1) : '*' x $l_in . ' ',
+										"$_\n"
+										for @l_names;
+								$desc = $l_in < $in;
+								@l_names = $name;
+							} else {
+								push @l_names, $name;
+							}
+						} else {
+							@l_names = $name;
+						}
 					$repstr = '';
 					$repcnt = 0;
 					$l_in = $in;
-					$l_name = $name;
 				}
-				$in += $tab;
+				}
+			}
+			    $in += $opt_w;
 			}
 			if( ! defined $names->{$name} ){
 				$names->{$name} = $name;
@@ -819,9 +884,21 @@
 		    die "Bad profile: $_";
 	        }
 	}
-	if( $opt_t ){
+	if( $opt_t ) {
 		$repstr = ' ('.++$repcnt.'x)' if $repcnt;
-		print ' ' x $l_in, "$l_name$repstr\n";
+	    if( $opt_o ) {
+			$l_names[-1] .= $repstr
+				if @l_names;
+			print $l_in > $in && $desc ? ' ' x ($l_in+1) : '*' x $l_in . ' ',
+				"$_\n"
+				for @l_names;
+	    } else {
+			print ' ' x $l_in, "@l_names$repstr\n";
+	    }
+	} elsif( $opt_o ) {
+	    print $l_in > $in && $desc ? ' ' x ($l_in+1) : '*' x $l_in . ' ',
+			"$_\n"
+			for @l_names;
 	}
 
         while (my ($key, $count) = each %outer) {
@@ -845,7 +922,7 @@
 				$name = $x->[0];
 				exitstamp( \@stack, \@tstack, 
 					   $t - $overhead, $times, 
-					   $ctimes, $name, \$in, $tab, 
+					   $ctimes, $name, \$in,
 					   $curdeep_times, \%outer );
 				add_to_tree($curdeep_times, $name,
 					    $t - $overhead)
@@ -860,7 +937,7 @@
 }
 
 sub exitstamp {
-	my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
+	my($stack, $tstack, $t, $times, $ctimes, $name, $in, $deep, $outer) = @_;
 	my( $x, $c, $z );
 
 	$x = pop( @$stack );
@@ -883,7 +960,7 @@
 	  }
 	}
 	if( $opt_T || $opt_t ){
-		$$in -= $tab;
+	    $$in -= $opt_w;
 	}
 	# collect childtime
 	$c = pop( @$tstack );
@@ -972,6 +1049,7 @@
     my $fmt = ' ^>>>   ^>>>> ^>>>>> ^>>>>>   ^>>>>> ^>>>>>  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
     if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
     {
+	$cols ||= $ENV{COLUMNS} || 0; # In Emacs stty reports 0.
 	$fmt .= '<' x ($cols - length $fmt) if $cols > 80;
     }
 

• dprofpp enhanced by Daniel Pfeiffer