Devel::Graph - Turn Perl code into a graphical flowchart

	use Devel::Graph;
	my $grapher = Devel::Graph->new();

	my $graph = $grapher->decompose( \'if ($b == 1) { $a = 9; }' );
	print $graph->as_ascii();

	# Will result in something like this:

	################
	#    start     #
	################
	  |
	  |
	  v
	+--------------+
	| if ($b == 1) |--+
	+--------------+  |
	  |               |
	  | true          |
	  v               |
	+--------------+  |
	|   $a = 9;    |  | false
	+--------------+  |
	  |               |
	  |               |
	  v               |
	################  |
	#     end      # <+
	################

	# Alternatively, read in code from a file
	my $graph_2 = $grapher->decompose( 'lib/Foo.pm' );
	print $graph_2->as_ascii();

	use Devel::Graph;
	my $g = Devel::Graph->graph( '$a = 9 if $b == 1' );

	$g->set_attribute('node.if', 'fill', 'red');    # if blocks: red
	$g->set_attribute('node.for', 'fill', 'blue');  # for blocks: blue
	$g->set_attribute('edge.true', 'style', 'bold');# true edges: bold
	print $g->as_html_file();

	my $graph = Devel::Graph->graph( \$code );
	my $graph = Devel::Graph->graph( $filename );

	my $code = \'$a = 9;';
	my $flow = Devel::Graph->new();
	$flow->decompose( $code );
	$flow->finish();
	my $graph = $grapher->as_graph();

	my $flow = Devel::Graph->new( $options );
	my $flow_2 = Devel::Graph->new( { strip_pod => 0 } );

	strip_pod	Strip all POD before doing the graph. Defaults to true.
			POD sections are usually very large, resulting in huge
			nodes, that can, f.i. crash graphviz or result in
			poor output quality.
	debug		Defaults to false. When set to true, enables debug output.
	fatal_errors	Defaults to true. When set to true, errors are fatal.

	my $option = $flow->option($name);

	my $debug = $grapher->debug();	# get
	$grapher->debug(1);		# enable
	$grapher->debug(0);		# disable

	$flow->decompose( \$code );		# \'$a = 1;'
	$flow->decompose( $filename );		# 'lib/Package.pm'

	$flow->finish();

	$flow->reset();

	my $graph = $flow->as_graph();

	print $flow->as_ascii();

	my $chart = $flow->as_flowchart();

#############################################################################
# Generate flowcharts from Perl code.
#
#############################################################################

package Devel::Graph;

use Graph::Easy;
use Graph::Easy::Base;
use Graph::Flowchart;
use Graph::Flowchart::Node qw/
  N_IF N_THEN N_ELSE N_JOINT N_BLOCK N_BODY
  N_SUB N_RETURN
  N_BREAK N_LAST N_GOTO N_CONTINUE N_NEXT
  N_FOR N_WHILE N_UNTIL
  /;

$VERSION = '0.12';

@ISA = qw/Graph::Easy::Base/;
@EXPORT_OK = qw/graph/;

use strict;
use PPI;

#############################################################################
#############################################################################

sub _init
  {
  my ($self, $args) = @_;

  $self->{options} = {};

  $self->{opt}->{strip_pod} = 1;
  $self->{opt}->{strip_pod} = ($args->{strip_pod} ? 1 : 0)
    if defined $args->{strip_pod};

  $self->{fatal_errors} = $args->{fatal_errors};
  $self->{fatal_errors} = 1 unless defined $self->{fatal_errors};

  $self->{debug} = $args->{debug} || 0;

  $self->reset();

  $self;
  }

sub option
  {
  my $self = shift;

  $self->{opt}->{$_[0]};
  }

sub debug
  {
  my $self = shift;

  $self->{debug} = $_[0] if @_;
  $self->{debug};
  }

sub graph
  {
  # decompose code and return as Graph::Easy object

  # allow the following styles:
  # Devel::Graph->graph($code);		@_ == 2  $class
  # Devel::Graph::graph($code);		@_ == 1
  # $grapher->graph($code);		@_ == 2  ref($self) == $class

  my $self = 'Devel::Graph';
  $self = shift if @_ == 2;
  my $code = shift;

  if (! ref($self) )
    {
    $self = $self->new();
    }
  $self->reset();
  $self->decompose($code);
  $self->{flow}->finish();

  $self->{flow}->as_graph();			# return the Graph::Easy object
  }

sub as_graph
  {
  # return the internal Graph::Easy object
  my $self = shift;

  $self->{flow}->as_graph();
  }

sub as_ascii
  {
  # return the flowchart as ASCII
  my $self = shift;

  $self->{flow}->as_graph()->as_ascii();
  }

sub as_flowchart
  {
  # return the internal Graph::Flowchart object
  my $self = shift;

  $self->{flow};
  }

sub decompose
  {
  my ($self, $code) = @_;

  $self->error("Expected SCALAR ref, but got " . ref($code))
   if ref($code) && ref($code) ne 'SCALAR';

  $self->error("Got filename '$code', but can't read it: $!")
   if !ref($code) && !-f $code;

  my $doc = PPI::Document->new($code);

  $self->error("Couldn't create PPI::Document from $code")
   unless ref($doc);

  $doc->prune('PPI::Token::Pod') if $self->{opt}->{strip_pod};

  $self->_parse($doc);

  $self;
  }

sub finish
  {
  my $self = shift;

  $self->{flow}->finish();
  }

sub reset
  {
  # reset the internal structure
  my $self = shift;

  Graph::Easy::Base->_reset_id();

  $self->{cur_group} = undef;
  $self->{stack} = [];
  $self->{flow} = Graph::Flowchart->new();
  $self->{flow}->{graph}->seed(0);

  $self;
  }

#############################################################################
#############################################################################
# _parse helper routines

sub _find_first
  {
  # return the first child of $element matching any of the given types
  my $self = shift;
  my $element = shift;

  for my $child (@{$element->{children}})
    {
    for my $type (@_)
      {
      return $child if $child->isa($type);
      }
    }

  undef;
  }

sub _find_second
  {
  # return the first child of $element matching any of the given types
  my $self = shift;
  my $element = shift;

  $self->error("Got non-object as element: $element") unless ref $element;

  my @blocks;
  for my $child (@{$element->{children}})
    {
    for my $type (@_)
      {
      push @blocks, $child if $child->isa($type);
      return $blocks[-1] if scalar @blocks == 2;
      }
    }

  undef;
  }

sub _find_on_stack
  {
  my ($self, $type) = @_;

  my $stack = $self->{stack};

  for my $e (@$stack)
    {
    return $e if $e->{_type} == $type;
    }

  undef;
  }

#############################################################################
#############################################################################

sub _parse_compound
  {
  my ($self, $element, $type) = @_;

  # work around bug in PPI
  $type = $element->type() unless defined $type;

  $self->error("Cannot determine type of compound element $element")
    unless defined $type;

  # closures (bug #29346)
  return $self->_parse($element->children)
    if $type eq 'continue';

  return $self->_parse_loop($element)
    if $type eq 'for' || $type eq 'foreach';
 
  $self->error("Cannot find condition: possible syntax error in $element")
    unless defined $self->_find_first($element,'PPI::Structure::Condition');

  # ignoring whitespace and comments, find the condition
  my @blocks;

  my $condition = $element->clone();

  my $in_cond = 0;
  my @children = @{$condition->{children}};

  for my $child (@children)
    {
    next unless $child->significant();

    if ($child->isa('PPI::Structure::Block'))
      {
      push @blocks, $child;
      $in_cond = 2;
      }

    $child->remove() unless $in_cond == 1;

    $in_cond = 1 if $in_cond == 0 && $child->isa('PPI::Token::Word');
    }

  ########################################################################
  ########################################################################
  # work around bug in PPI for "unless" having type() return 'if'
  if ($type eq 'if')
    {
    my $c = $element->find_first('PPI::Token::Word');
    $type = 'unless' if $c eq 'unless';
    }
  ########################################################################
  ########################################################################

  ########################################################################
  ########################################################################
  # work around bug in PPI for "until" having type() return 'while'
  if ($type eq 'while')
    {
    my $c = $element->find_first('PPI::Token::Word');
    $type = 'until' if $c eq 'until';
    }
  ########################################################################
  ########################################################################

  $condition = $self->_normalize_condition($condition);

  return $self->_parse_if($type, $condition, @blocks)
    if $type =~ /^(if|unless)\z/;

  return $self->_parse_while($type, $condition, @blocks)
    if $type =~ /^(until|while)\z/;

  $self->error("Unknown conditional type $type");
  }

sub _normalize_condition
  {
  my ($self, $condition) = @_;

  my $text = $condition->content();

  $text =~ s/^\s+//;
  $text =~ s/\s+\z//;

  $text;
  }

sub _parse_if
  {
  my ($self, $type, $condition, $block, $else_block) = @_;

  $self->error('Undefined block in if expression') unless defined $block;

  my $flow = $self->{flow};

  # cur => if => then => joint
  #        |--------------^
  
  my $if = $flow->add_new_block('if ' . $condition, N_IF());

  my @edges = ('true','false');
  @edges = ('false','true') if $type eq 'unless';

  # cur => if => then
  my $then = $flow->add_joint(); 
  my $then_edge = $flow->connect($if,$then,$edges[0]);

  $flow->current_block($then);

  # fill in the "then" block
  $self->_parse($block);
  my $last_then = $flow->add_new_joint();

  if ($else_block)
    {
    # cur => if =====> then => joint
    #        --false-> else => ---^

    my $else_joint = $flow->add_joint();

    my $else_edge = $flow->connect($if,$else_joint,$edges[1]);
    $flow->current_block($else_joint);

    $self->_parse($else_block);
    
    my $l_joint = $flow->add_new_joint();

    $flow->connect($l_joint,$last_then);
    }
  else
    {
    # connect the "if" block with the newly added joint
    # cur => if => then => joint
    #        ----false--------^
  
    # add a dummy-joint
    $flow->connect($if,$last_then,$edges[1]);
    }
  $flow->current($last_then);
  }

sub _parse_sub
  {
  my ($self, $sub) = @_;

  my $name = $self->_find_second($sub, 'PPI::Token::Word');
  
  my $flow = $self->{flow};

  $flow->add_group("sub $name:");

  # remember pos before sub
  my $cur = $flow->current();

  # entry point
  my $joint = $flow->add_joint(); $joint->{_label} = $name;
  $flow->current($joint);

  # recurse into our children, but ignore:
  # whitespace and comments and Null (";")
  foreach my $child (@{$sub->{children}})
    {
    $self->_parse($child) if $child->significant();
    }

  # continue at pos before sub
  $flow->current($cur);
  $flow->no_group();

  }

sub _parse_while
  {
  # add while() or until() loops
  my ($self, $type, $condition, $body, $continue) = @_;

  #  |----------- false ------------v
  # while () -- true --> body -> continue    * 
  #  ^----------------------------|

  my $flow = $self->{flow};
  my $t = N_WHILE; $t = N_UNTIL if $type eq 'until';
  my @edges = ('true','false');
  @edges = ('false','true') if $type eq 'until';

  my $while = $flow->add_new_block( "$type $condition", $t);
  my $body_block = $flow->add_joint();

  # -- true -->
  my $true = $flow->connect($while,$body_block, $edges[0]);
  # make the true edge start at the right side (perpendicular to flow)
  $true->set_attribute('start','right') if $type eq 'until';

  $body_block->set_attributes( {
    offset => '-2,0',
    origin => $while->name(),
    });

  $flow->current($body_block);

  # insert the body
  $self->_parse($body);

  if (defined $continue)
    {
    # connect the body to the continue block
    my $cont_block = $flow->add_new_joint();
    $self->_parse($continue);
    }

  # connect body (or continue) back to while
  my $back = $flow->connect($flow->current(), $while);
  # make the back edge end at the right side (perpendicular to flow)
  $back->set_attribute('end','right,1');

  # connect body to next
  my $next = $flow->add_joint();

  my $forward = $flow->connect($while, $next, $edges[1]);

  # make that edge go forwards 
  $forward->set_attribute('flow','forward');

  $flow->current($next);
  }

sub _parse_loop
  {
  my ($self, $element) = @_;

#  PPI::Statement::Compound
#    PPI::Token::Word    'for'
#    PPI::Structure::ForLoop     ( ... )
#      PPI::Statement::Variable
#        PPI::Token::Word        'my'
#        PPI::Token::Symbol      '$i'
#        PPI::Token::Operator    '='
#        PPI::Token::Number      '0'
#        PPI::Token::Structure   ';'
#      PPI::Statement
#        PPI::Token::Symbol      '$i'
#        PPI::Token::Operator    '<'
#        PPI::Token::Number      '10'
#        PPI::Token::Structure   ';'
#      PPI::Statement
#        PPI::Token::Symbol      '$i'
#        PPI::Token::Operator    '++'
#    PPI::Structure::Block       { ... }
#      PPI::Statement
#        PPI::Token::Symbol      '$b'
#        PPI::Token::Operator    '++'
#        PPI::Token::Structure   ';'

#  PPI::Statement::Compound
#    PPI::Token::Word    'for'
#    PPI::Token::Word    'my'
#    PPI::Token::Symbol          '$i'
#    PPI::Structure::ForLoop     ( ... )
#      PPI::Statement
#        PPI::Token::Symbol      '@list'
#    PPI::Structure::Block       { ... }
#      PPI::Statement
#        PPI::Token::Word        'print'
#        PPI::Token::Symbol      '$foo'

  my $loop = $self->_find_first($element, 'PPI::Structure::ForLoop');

  my (@bodies, @blocks, @var);
  # get the stuff inside the ()
  foreach my $child (@{$loop->{children}})
    {
    push @blocks, $child if $child->isa('PPI::Statement');
    }
  # get the body (and continue) block
  foreach my $child (@{$element->{children}})
    {
    push @bodies, $child if $child->isa('PPI::Structure::Block');
    }
  # get the variable in front of the () for foreach loops
  foreach my $child (@{$element->{children}})
    {
    push @var, $child->content() if $child->isa('PPI::Token::Word') || $child->isa('PPI::Token::Symbol');
    }
  shift @var;	# remove the "for" so that "for my $i" results in "my $i";

  my $flow = $self->{flow};
  if (@blocks == 1)
    {
    # 'for my $var (@list)'

    my $v = join(" ", @var);
    $blocks[0] = 'for ' . $v . " ($blocks[0])";
    push @blocks, '';

    #  |-----last------v
    # for ---> body    *
    #  ^--------|
    
    # XXX TODO: 
    # technically, we need to parse $blocks[0]!

    my $for_block = $flow->add_new_block($blocks[0], N_FOR());
    my $body_block = $flow->add_new_joint();

    # insert the '*' for "next"
    my $next = $flow->add_joint();

    # insert the body
    $self->_parse($bodies[0]);

    # connect the body back to the for
    my $cur = $flow->current();
    if ($cur->{_type} == N_JOINT)
      {
      # XXX TODO: if current is a joint, eliminate it
      # move all incoming edges to point directly to 'for'
      $flow->connect($cur, $for_block, 'next');
      }
    else
      {
      $flow->connect($cur, $for_block, 'next');
      }

    my $last = $flow->connect($for_block, $next, 'last');
    $last->set_attribute('flow','forward');
   
    $flow->current($next);

    return;
    }

  # init -> if $while --> body --> cont --> (back to if)

  # XXX TODO: 
  # technically, we need to parse $blocks[x]!

  my $next = $flow->add_joint();
  my $for_block = $flow->add_new_block('for: ' . $blocks[0], N_FOR());
  my $while_block = $flow->add_new_block('while ' . $blocks[1], N_WHILE());
  
  my $body_block = $flow->add_joint();

  $flow->connect($while_block, $body_block, 'true');

  # insert the body
  $flow->current($body_block);
  $self->_parse($bodies[0]);

  my $cur = $flow->current();
  my $cont_block = $flow->add_new_block($blocks[2], N_BLOCK());

  my $false = $flow->connect($while_block, $next, 'false');
  $false->set_attribute('flow','forward');

  $flow->connect($cont_block, $while_block, 'continue');

  $flow->current($next);
  }

sub _parse_conditional
  {
  # parse a statement with a trailing condition/loop
  my ($self, $element) = @_;

# PPI::Statement
#    PPI::Token::Word    'print'
#    PPI::Token::Symbol          '$a'
#    PPI::Token::Operator        '++'
#    PPI::Token::Word    'if'				<-- type
#    PPI::Structure::Condition   ( ... )		<-- condition start
#      PPI::Statement::Expression
#        PPI::Token::Symbol      '$a'
#        PPI::Token::Operator    '<'
#        PPI::Token::Number      '9'
  
  # gather all elements up to the condition
  my @blocks;
  my $condition;

  for my $child (@{$element->{children}})
    {
    next unless $child->significant();		# ignore whitespace etc
    push @blocks, $child;
    $condition = $child->snext_sibling(), last 
     if $child->isa('PPI::Token::Word') && $child =~ /^(if|unless|until|while)\z/;
    }

  my $type = pop @blocks;			# if, unless, until, or while

  # make a copy and delete the condition and the word before it
  # to get only the block of the condition:

  my $block = $element->clone();
  my $c = $block->find_first('PPI::Structure::Condition');
  my $t = $c->sprevious_sibling();
  $c->delete();
  $t->delete();

  # delete trailing whitespace in $block (so that "$c = 123 ;" turns in "$c = 123;"
  for my $child (reverse @{$block->{children}})
    {
    # remove the trailing ";" because otherwise:
    # "print $a++ if (...)" would turn into 		"print $a++"
    # while "print $a++ if (...);" would turn into 	"print $a++;"

    # stop at the first significant child other than the ";"
    $child->delete() && next if $child->isa('PPI::Token::Structure') && $child eq ';';
    last if $child->significant(); 
    $child->delete();
    }
  
  return $self->_parse_if($type, $condition, $block)
    if $type =~ /^(if|unless)\z/;

  return $self->_parse_while($type, $condition, $block)
    if $type =~ /^(until|while)\z/;

  $self->error("Unknown conditional type $type");
  }

my $types = {
  'return' => N_RETURN(),
  'last' => N_LAST(),
  'break' => N_BREAK(),
  'continue' => N_CONTINUE(),
  'goto' => N_GOTO(),
  'next' => N_NEXT(),
  };

sub _parse_break
  {
  my ($self, $element) = @_;

  # find the type of the break statement
  my $type = $self->_find_first($element, 'PPI::Token::Word');

  my $flow = $self->{flow};

  my $target;
  if ($type ne 'return')
    {
    my $t = $types->{"$type"};
    $self->error("Unrecognized break type $type") unless defined $t;

    # ignore first Token::Word
    $target = $self->_find_second($element, 'PPI::Token::Word');
    $flow->add_jump(
	$element->content(),		# "last FOO;"
	$t, 				# N_BREAK etc
	'',
	$target->content());		# "FOO"
    }
  else
    {
    $flow->add_new_block($element->content(), N_RETURN(), '');
    }
  }

#############################################################################

sub _parse_expression
  {
  my ($self, $element) = @_;

  my $flow = $self->{flow};

  $flow->add_new_block( $element->content(), N_BLOCK());
  }

#############################################################################
#############################################################################
# main parse routine, recursive

sub _error
  {
  require Carp;

  Carp::confess($_);
  }

sub _parse
  {
  # take a PPI::ELement and descend into it recursively
  no warnings 'recursion';
  my ($self, $element) = @_;

#  print STDERR "parsing ", ref($element)," ($element)\n";

  $self->error('Encountered an undefined element while parsing')
    unless defined $element;

  # handle 'if', 'while', 'for', 'until' as compound statements
  # Example: until ($a < 9) { $b++; }
  return $self->_parse_compound($element)
    if $element->isa('PPI::Statement::Compound');

  # handle sub 
  return $self->_parse_sub($element)
    if $element->isa('PPI::Statement::Sub');

  # handle next, last, return and break
  return $self->_parse_break($element)
    if $element->isa('PPI::Statement::Break');

  # Example: "$a = 9 if ($b == 9);" - note the "()"!
  return $self->_parse_conditional($element)
    if (ref($element) eq 'PPI::Statement' && $element->find_any('PPI::Structure::Condition'));

  # Example: "$a = 9 if $b == 9;" - note the missing "()"!
  if (ref($element) eq 'PPI::Statement')
    {
    my $c = $element->find_first('PPI::Token::Word');
    return $self->_parse_conditional($element) if $c =~ /^(if|unless)\z/;
    }

  # handle normal expressions like:
  # "$a == 1"
  # "use strict;"
  return $self->_parse_expression($element)
    if ( $element->isa('PPI::Statement')   );
#        ($element->isa('PPI::Statement::Expression')) ||
#        ($element->isa('PPI::Statement::Include'))    );

  # recurse into our children, but ignore whitespace, comments, Null (";") etc:
  if ($element->isa('PPI::Node'))
    {
    foreach my $child (@{$element->{children}})
      {
      $self->_parse($child) if $child->significant();
      }
    }
  }

1;
__END__