File Coverage

lib/Devel/Graph.pm

Criterion	Covered	Total	%
statement	232	270	85.9
branch	95	122	77.8
condition	20	28	71.4
subroutine	25	31	80.6
pod	9	9	100.0
total	381	460	82.8

#############################################################################
# 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__