Devel::GraphVizProf - per-line Perl profiler (with graph output)

	perl -d:GraphVizProf test.pl > test.dot
        dot -Tpng test.dot > test.png

        <num> <time> <ctime> <line>:<text>

	perl5 -d:GraphVizProf test.pl

	sort -k 2nr,2 smallprof.out | less

	open(PROF,"smallprof.out");
	@sorted = sort {(split(/\s+/,$b))[2] <=> 
                        (split(/\s+/,$a))[2]} <PROF>;
        close PROF;
	print join('',@sorted);

	perl Makefile.PL
	make
	make test
	make install

package Devel::GraphVizProf; # To help the CPAN indexer to identify us

$Devel::GraphVizProf::VERSION = '0.8';

package DB;

require 5.000;

use Time::HiRes 'time';

use strict;

BEGIN {
  $DB::drop_zeros = 0;
  $DB::profile = 1;
  if (-e '.smallprof') {
    do '.smallprof';
  }
  $DB::prevf = '';
  $DB::prevl = 0;
  my($diff,$cdiff);

  my($testDB) = sub {
    my($pkg,$filename,$line) = caller;
    $DB::profile || return;
    %DB::packages && !$DB::packages{$pkg} && return;
  };

  # "Null time" compensation code
  $DB::nulltime = 0;
  for (1..100) {
    my($u,$s,$cu,$cs) = times;
    $DB::cstart = $u+$s+$cu+$cs;
    $DB::start = time;
    &$testDB;
    ($u,$s,$cu,$cs) = times;
    $DB::cdone = $u+$s+$cu+$cs;
    $DB::done = time;
    $diff = $DB::done - $DB::start;
    $DB::nulltime += $diff;
  }
  $DB::nulltime /= 100;

  my($u,$s,$cu,$cs) = times;
  $DB::cstart = $u+$s+$cu+$cs;
  $DB::start = time;
}

sub DB {
  my($pkg,$filename,$line) = caller;
  $DB::profile || return;
  %DB::packages && !$DB::packages{$pkg} && return;
  my($u,$s,$cu,$cs) = times;
  $DB::cdone = $u+$s+$cu+$cs;
  $DB::done = time;

  # Now save the _< array for later reference.  If we don't do this here, 
  # evals which do not define subroutines will disappear.
  no strict 'refs';
  $DB::listings{$filename} = \@{"main::_<$filename"} if 
    defined(@{"main::_<$filename"});
  use strict 'refs';

#  warn $DB::prevl . " -> " . $line . "\n";
#  $DB::calls{$DB::prevf}->{$DB::prevl}->{$filename}->{$line}++;
  $DB::calls{$filename}->{$line}->{$DB::prevf}->{$DB::prevl}++;

  my($delta);
  $delta = $DB::done - $DB::start;
  $delta = ($delta > $DB::nulltime) ? $delta - $DB::nulltime : 0;
  $DB::profiles{$filename}->[$line]++;
  $DB::times{$DB::prevf}->[$DB::prevl] += $delta;
  $DB::ctimes{$DB::prevf}->[$DB::prevl] += ($DB::cdone - $DB::cstart);
  ($DB::prevf, $DB::prevl) = ($filename, $line);

  ($u,$s,$cu,$cs) = times;
  $DB::cstart = $u+$s+$cu+$cs;
  $DB::start = time;
}

END {

  # Get time on last line executed.
  my($u,$s,$cu,$cs) = times;
  $DB::cdone = $u+$s+$cu+$cs;
  $DB::done = time;
  my($delta);
  $delta = $DB::done - $DB::start;
  $delta = ($delta > $DB::nulltime) ? $delta - $DB::nulltime : 0;
  $DB::times{$DB::prevf}->[$DB::prevl] += $delta;
  $DB::ctimes{$DB::prevf}->[$DB::prevl] += ($DB::cdone - $DB::cstart);


  # Now write out the results.
#  open(OUT,">graphvizprof.dot");
#  select OUT;
  my($i,$stat,$time,$ctime,$line,$file,$page);
  $page = 1;

  my %seenlabel;
  my $maxcalls = 1;
  my $maxtime = 0;

  foreach $file (sort keys %DB::profiles) {
    $- = 0;
    if (defined($DB::listings{$file})) {
      $i = -1;
      foreach $line (@{$DB::listings{$file}}) {
        ++$i or next;
        my $time = defined($DB::ctimes{$file}->[$i]) ? $DB::ctimes{$file}->[$i] : 0;
        $maxtime = $time if $time > $maxtime;
	foreach my $file (sort keys %{$DB::calls{$file}->{$i}}) {
	  foreach my $j (sort {$a <=> $b} keys %{$DB::calls{$file}->{$i}->{$file}}) {
	    my $calls = $DB::calls{$file}->{$i}->{$file}->{$j};
	    $maxcalls = $calls if $calls > $maxcalls;
	  }
	}
      }
    }
  }

  use GraphViz;

  my $g = GraphViz->new();


  foreach $file (sort keys %DB::profiles) {
    $- = 0;
    if (defined($DB::listings{$file})) {
      $i = -1;
      foreach $line (@{$DB::listings{$file}}) {
        ++$i or next;
	$line = "" unless defined $line;
        chomp($line);
        $stat = $DB::profiles{$file}->[$i] || 0 or !$DB::drop_zeros or next;
        $time = defined($DB::times{$file}->[$i]) ?
	  $DB::times{$file}->[$i] : 0;
        $ctime = defined($DB::ctimes{$file}->[$i]) ?
	  $DB::ctimes{$file}->[$i] : 0;
	my $label = getlabel($file . $i);
	my $name = getname($file, $i);
	foreach my $file (sort keys %{$DB::calls{$file}->{$i}}) {
	  foreach my $j (sort {$a <=> $b} keys %{$DB::calls{$file}->{$i}->{$file}}) {
	    my $calls = $DB::calls{$file}->{$i}->{$file}->{$j};
#	    next unless $calls > 2;
	    my $fromlabel = getlabel($file . $j);
	    my $ratio = $ctime / $maxtime;
	    $g->add_node("$file/$name", label => $name, color => "0,1,$ratio") unless ($name =~ m|/| || $seenlabel{"$file/$name"}++);
	    my $fromtime = defined($DB::ctimes{$file}->[$j]) ?
	      $DB::times{$file}->[$j] : 0;
	    $ratio = $fromtime / $maxtime;
	    my $fromname = getname($file, $j);
	    $g->add_node("$file/$fromname", label => $fromname, color => "0,1,$ratio") unless $seenlabel{"$file/$fromname"}++;
	    my $ratio = $calls / $maxcalls; 
	    my $w = 100 * (1 - $ratio);
	    $g->add_edge("$file/$fromname" => "$file/$name", color => "0,1,$ratio", w => $w, len => 2);
	  }
	}
      }
    } else {
#      print "# The code for $file is not in the symbol table.";
    } 
  }

  print $g->_as_debug;
}

sub getname {
  my($file, $lineno) = @_;
#  return "$file line $lineno";
  my $line = $DB::listings{$file}->[$lineno];
  $line = "" unless defined $line;
  chomp $line;
  $line =~ s|"|\\"|g;
  $line =~ s|^\s+||g;
#  return "$file: $lineno";
#  return "$lineno: $line";
  return $line;
}

{ 
my $labelcount;
my %label;
sub getlabel {
  my $url = shift;
  return $label{$url} if exists $label{$url};
  $labelcount++;
#  warn "miss $url\n";
  my $label = 'n' . $labelcount;
  $label{$url} = $label;
  return $label;
}
}


sub sub {
  no strict 'refs';
  goto &$DB::sub unless $DB::profile;
  if (defined($DB::sub{$DB::sub})) {
    my($m,$s) = ($DB::sub{$DB::sub} =~ /.+(?=:)|[^:-]+/g);
    $DB::profiles{$m}->[$s]++;
    $DB::listings{$m} = \@{"main::_<$m"} if defined(@{"main::_<$m"});
  }
  goto &$DB::sub;
}

1;

__END__