File Coverage

lib/Graph/Flowchart.pm

Criterion	Covered	Total	%
statement	82	261	31.4
branch	17	120	14.1
condition	5	36	13.8
subroutine	16	38	42.1
pod	34	34	100.0
total	154	489	31.4

#############################################################################
# Generate flowcharts as a Graph::Easy object
#

package Graph::Flowchart;

$VERSION = '0.11';

use strict;

use Graph::Easy;
use Graph::Flowchart::Node qw/
  N_IF N_THEN N_ELSE
  N_END N_START N_BLOCK N_JOINT
  N_FOR N_CONTINUE N_GOTO
  /;

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

sub new
  {
  my $class = shift;

  my $self = bless {}, $class;

  my $args = $_[0]; $args = { @_ } if ref($args) ne 'HASH';

  $self->_init($args);
  }

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

  $self->{graph} = Graph::Easy->new();

  # make the chart flow down
  my $g = $self->{graph};
  $g->set_attribute('flow', 'down');

  # set class defaults
  $g->set_attribute('node.joint', 'shape', 'point');
  $g->set_attribute('node.start', 'border-style', 'bold');
  $g->set_attribute('node.end', 'border-style', 'bold');
  for my $s (qw/block if for/)
    {
    $g->set_attribute("node.$s", 'border-style', 'solid');
    }
#  $g->set_attribute('edge.true', 'flow', 'front');
#  $g->set_attribute('edge.false', 'flow', 'front');

  # add the start node
  $self->{_last} = $self->new_block ('start', N_START() );

  $g->add_node($self->{_last});
#  $g->debug(1);

  $self->{_first} = $self->{_last};
  $self->{_cur} = $self->{_last};

  $self->{_group} = undef;

  $self;
  }

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

  $self->{graph};
  }

sub as_ascii
  {
  my $self = shift;

  $self->{graph}->as_ascii();
  }

sub as_html_file
  {
  my $self = shift;

  $self->{graph}->as_html_file();
  }

sub as_boxart
  {
  my $self = shift;

  $self->{graph}->as_boxart();
  }

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

sub last_block
  {
  # get/set the last block
  my $self = shift;

  $self->{_last} = $_[0] if ref($_[0]) && $_[0]->isa('Graph::Flowchart::Node');

  $self->{_last};
  }

sub current_block
  {
  # get/set the current insertion point
  my $self = shift;

  $self->{_cur} = $_[0] if ref($_[0]) && $_[0]->isa('Graph::Flowchart::Node');

  $self->{_cur};
  }

sub current
  {
  # get/set the current insertion point
  my $self = shift;

  $self->{_cur} = $_[0] if ref($_[0]) && $_[0]->isa('Graph::Flowchart::Node');

  $self->{_cur};
  }

sub first_block
  {
  # get/set the first block
  my $self = shift;

  $self->{_first} = $_[0] if ref($_[0]) && $_[0]->isa('Graph::Flowchart::Node');

  $self->{_first};
  }

sub make_current
  {
  # set the current insertion point, and convert it to a joint
  my $self = shift;

  $self->{_cur} = $_[0] if ref($_[0]) && $_[0]->isa('Graph::Flowchart::Node');

  $self->{_cur}->{_type} = N_JOINT();

  $self->{_cur};
  }

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

sub add_group
  {
  # add a group, and set it as current.
  my ($self, $name) =@_;

  my $g = $self->{graph};

  $self->{_group} = $g->add_group($name);
  }

sub no_group
  {
  # we are now outside the group, so forget it
  my $self = shift;

  $self->{_group} = undef;
  }

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

sub new_block
  {
  my ($self, $text, $type, $label) = @_;

  Graph::Flowchart::Node->new( $text, $type, $label, $self->{_group} );
  }

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

sub merge_blocks
  {
  # if possible, merge the given two blocks
  my ($self, $first, $second) = @_;

  # see if we should merge the blocks

  return $second
	if ( ($first->{_type} != N_JOINT()) &&
	     ($first->{_type} != $second->{_type} ) );

  my $label = $first->label();
  $label .= '\n' unless $label eq '';
  $label .= $second->label();

# print STDERR "# merge $first->{name} ", $first->label(), " $second->{name} ", $second->label(),"\n";

  $first->sub_class($second->sub_class()) if $first->{_type} == N_JOINT;

  # quote chars
  $label =~ s/([^\\])\|/$1\\\|/g;	# '|' to '\|' ("|" marks an attribute split)
  $label =~ s/([^\\])\|/$1\\\|/g;	# do it twice for "||"

  $first->set_attribute('label', $label);

  $first->{_type} = $second->{_type};

  # drop second node from graph
  my $g = $self->{graph};
  $g->merge_nodes($first, $second);

  $self->{_cur} = $first;
  }

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

sub connect
  {
  my ($self, $from, $to, $edge_label, $edge_class) = @_;

  my $g = $self->{graph};
  my $edge = $g->add_edge($from, $to);

  $edge->set_attribute('label', $edge_label) if defined $edge_label;
  $edge->sub_class($edge_class) if defined $edge_class;

  $edge;
  }

sub insert_block
  {
  # Insert a block to the current (or $where) block. Any outgoing connections
  # from $where are moved to the new block (unless they are merged).
  my ($self, $block, $where) = @_;

  # XXX TODO: if $where is a N_BLOCK() and $block a scalar, then
  # simple append $block to $where->label() and spare us the
  # creation of a new block, and then merging it into $where.

  $block = $self->new_block($block, N_BLOCK() ) unless ref $block;

  $where = $self->{_cur} unless defined $where;
  my $g = $self->{graph};
  $g->add_edge($where, $block);

  my $old = $block;
  $block = $self->merge_blocks($where, $block);

  if ($block != $old)
    {
    # where not merged, so move outgoing connections from $where to $block

    for my $e (values %{$where->{edges}})
      {
      # move the edge, unless is an incoming edge or a selfloop
      $e->start_at($block) if $e->{from} == $where && $e->{to} != $where;
      }
    }

  $self->{_cur} = $block;			# set new _cur and return it
  }

sub add_block
  {
  # Add a block to the current (or $where) block. Any outgoing connections
  # are left where they are, e.g. starting at $where.

  my ($self, $block, $where, $edge_label) = @_;

  # XXX TODO: if $where is a N_BLOCK() and $block a scalar, then
  # simple append $block to $where->label() and spare us the
  # creation of a new block, and then merging it into $where.

  $block = $self->new_block($block, N_BLOCK() ) unless ref $block;

  $where = $self->{_cur} unless defined $where;
  my $g = $self->{graph};
  $g->add_edge($where, $block, $edge_label);

  $block = $self->merge_blocks($where, $block);

  $self->{_cur} = $block;			# set new _cur and return it
  }

sub add_new_block
  {
  # shortcut for "add_block(new_block(...))"
  my ($self, $text, $type, $label, $where, $edge_label) = @_;

  my $block = $self->new_block($text, $type, $label);

  $self->add_block($block,$where);
  }

sub insert_new_block
  {
  # shortcut for "insert_block(new_block(...))"
  my ($self, $text, $type, $label, $where) = @_;

  my $block = $self->new_block($text, $type, $label);

  $self->insert_block($block,$where);
  }

sub add_new_joint
  {
  # shortcut for "add_block(new_block(.., N_JOINT()))"
  my ($self, $where) = @_;

  my $block = $self->new_block('', N_JOINT());
  $self->add_block($block,$where);
  }

sub insert_new_joint
  {
  # shortcut for "insert_block(new_block(.., N_JOINT()))"
  my ($self, $where) = @_;

  my $block = $self->new_block('', N_JOINT());
  $self->insert_block($block,$where);
  }

sub add_joint
  {
  my $self = shift;

  my $g = $self->{graph};

  my $joint = $self->new_block('', N_JOINT());
  $g->add_node($joint);

  # connect the requested connection points to the joint
  for my $node ( @_ )
    {
    $g->add_edge($node, $joint);
    }

  $joint;
  }

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

  my $g = $self->{graph};

  for my $n (values %{$g->{nodes}})
    {
    return $n if defined $n->{_label} && $n->{_label} eq $label;	# found
    }
  undef;					# not found
  }

sub collapse_joints
  {
  # find any left-over joints and remove them
  my ($self) = @_;

  my $g = $self->{graph};

  my @joints;
  for my $n (values %{$g->{nodes}})
    {
    push @joints, $n if $n->{_type} == N_JOINT();
    }

  for my $j (@joints)
    {
    # a joint should have only one successor
    my @out = $j->outgoing();
    next if @out != 1;

    my $o = $out[0]->{to};

    # get the label from the outgoing edge, if any
    my $label = $out[0]->label();

    # "next" to ", next"
    $label = ', ' . $label if $label ne '';

    # get all incoming edges
    my @in = $j->incoming();

    # now for each incoming edge, add one bypass
    for my $e (@in)
      {
      my $from = $e->{from};
      my $l = $e->label() . $label;

      $g->add_edge($e->{from}, $o, $l);
      }

    # finally get rid of the joint (including all edges)
    $g->del_node($j);
    }

  $self;
  }

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

sub start_node
  {
  # return the START node
  my $self = shift;

  $self->{_first};
  }

sub end_node
  {
  # return the END node (or, before finish is called, the current last node)
  my $self = shift;

  $self->{_last};
  }

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

  my $end = $self->new_block ( 'end', N_END() );
  $end = $self->add_block ($end, $where);
  $self->{_last} = $end;

  $self->collapse_joints();

  # If there is only one connection from START, and it goes to END, delete
  # both blocks. This makes things like "sub foo { $a++; }" look better.
  my $start = $self->{_first};

  my $g = $self->{graph};

  # if we only have two node, then we parsed something like '' and let it be:
  if ($g->nodes() > 2)
    {
    # XXX TODO: use ->edges() and Graph::Easy 0.50
    my @edges = values %{$start->{edges}};
    if (@edges == 1 && $edges[0]->to() == $end)
      {
      $g->del_node($start);
      $g->del_node($end);
      }
    }

  $self;
  }

#############################################################################
#############################################################################
# convience methods, for constructs like if, for etc

sub add_jump
  {
  my ($self, $text, $type, $label, $target, $where) = @_;

  # find target if it was not specified as block
  $target = $self->find_target($target) unless ref($target);

  if (!defined $target)
    {
    $target = $self->new_block ('', N_JOINT(), $target);
    $self->{graph}->add_node($target);
    }

  my $jump = $self->insert_new_block($text, $type);

  my $l = $target->{_label}; $l = '' unless defined $l;
  $l = ' '.$l if $l ne '';

  # connect to the target block
  my $edge = $self->connect($jump, $target, "$type$l", $type);
  $self->{_cur} = $target;

  return ($jump,$target) if wantarray;

  $jump;
  }

sub add_if_then
  {
  my ($self, $if, $then, $where) = @_;

  $if = $self->new_block($if, N_IF()) unless ref $if;
  $then = $self->new_block($then, N_THEN()) unless ref $then;

  $where = $self->{_cur} unless defined $where;

  $if = $self->insert_block ($if, $where);

  $self->connect($if, $then, 'true', 'true');

  # then --> '*'
  $self->{_cur} = $self->add_joint($then);

  # if -- false --> '*'
  $self->connect($if, $self->{_cur}, 'false', 'false');

  return ($if, $then, $self->{_cur}) if wantarray;

  $self->{_cur};
  }

sub add_if_then_else
  {
  my ($self, $if, $then, $else, $where) = @_;

  return $self->add_if_then($if,$then,$where) unless defined $else;

  $if = $self->new_block($if, N_IF()) unless ref $if;
  $then = $self->new_block($then, N_THEN()) unless ref $then;
  $else = $self->new_block($else, N_ELSE()) unless ref $else;

  $where = $self->{_cur} unless defined $where;

  $if = $self->insert_block ($if, $where);

  $self->connect($if, $then, 'true', 'true');
  $self->connect($if, $else, 'false', 'false');

  # then --> '*', else --> '*'
  $self->{_cur} = $self->add_joint($then, $else);

  return ($if, $then, $else, $self->{_cur}) if wantarray;
  $self->{_cur};
  }

#############################################################################
# for loop

sub add_for
  {
  # add a for (my $i = 0; $i < 12; $i++) style loop
  my ($self, $init, $while, $cont, $body, $where) = @_;

  $init = $self->new_block($init, N_FOR()) unless ref $init;
  $while = $self->new_block($while, N_IF()) unless ref $while;
  $cont = $self->new_block($cont, N_CONTINUE()) unless ref $cont;
  $body = $self->new_block($body, N_BLOCK()) unless ref $body;

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

  $where = $self->{_cur} unless defined $where;

  $init = $self->add_block ($init, $where);
  $while = $self->add_block ($while, $init);

  # Make the for-head node a bigger because it has two edges leaving it, and
  # one coming back and we want two of them on one side for easier layouts:
  $while->set_attribute('rows',2);

  $self->connect($while, $body, 'true', 'true');

  $self->connect($body, $cont);
  $self->connect($cont, $while);

  my $joint = $self->add_joint();
  $self->connect($while, $joint, 'false', 'false');

  $self->{_cur} = $joint;

  ($joint, $body, $cont);
  }

sub add_foreach
  {
  # add a for (@list) style loop
  my ($self, $list, $body, $cont, $where) = @_;

  $list = $self->new_block($list, N_FOR()) unless ref $list;
  $body = $self->new_block($body, N_BLOCK()) unless ref $body;
  $cont = $self->new_block($cont, N_CONTINUE()) if defined $cont && !ref $cont;

  # list --> body --> cont --> (back to list)

  $where = $self->{_cur} unless defined $where;

  $list = $self->add_block ($list, $where);

  # Make the for-head node a bigger because it has two edges leaving it, and
  # one coming back and we want two of them on one side for easier layouts:
  $list->set_attribute('rows',2);

  $self->connect($list, $body, 'true', 'true');

  if (defined $cont)
    {
    $self->connect($body, $cont);
    $self->connect($cont, $list);
    }
  else
    {
    $self->connect($body, $list);
    }

  my $joint = $self->add_joint();
  $self->connect($list, $joint, 'false', 'false');

  $self->{_cur} = $joint;

  ($joint, $body, $cont);
  }

#############################################################################
# while loop

sub add_while
  {
  # add a "while ($i < 12) { body } continue { cont }" style loop
  my ($self, $while, $body, $cont, $where) = @_;

  $while = $self->new_block($while, N_IF()) unless ref $while;

  # no body?
  $body = $self->new_block( '', N_JOINT()) if !defined $body;
  $body = $self->new_block($body, N_BLOCK()) unless ref $body;

  $cont = $self->new_block($cont, N_CONTINUE()) if defined $cont && !ref $cont;

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

  $where = $self->{_cur} unless defined $where;

  $while = $self->add_block ($while, $where);

  # Make the head node a bigger because it has two edges leaving it, and
  # one coming back and we want two of them on one side for easier layouts:
  $while->set_attribute('rows',2);

  $self->connect($while, $body, 'true', 'true');

  if (defined $cont)
    {
    $cont = $self->add_block ($cont, $body);
    $self->connect($cont, $while);
    }
  else
    {
    $self->connect($body, $while);
    }

  my $joint = $self->add_joint();
  $self->connect($while, $joint, 'false', 'false');

  $self->{_cur} = $joint;

  ($joint, $body, $cont);
  }

sub add_until
  {
  # add a "until ($i < 12) { body } continue { cont }" style loop
  my ($self, $while, $body, $cont, $where) = @_;

  $while = $self->new_block($while, N_IF()) unless ref $while;

  # no body?
  $body = $self->new_block( '', N_JOINT()) if !defined $body;
  $body = $self->new_block($body, N_BLOCK()) unless ref $body;

  $cont = $self->new_block($cont, N_CONTINUE()) if defined $cont && !ref $cont;

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

  $where = $self->{_cur} unless defined $where;

  $while = $self->add_block ($while, $where);

  # Make the head node a bigger because it has two edges leaving it, and
  # one coming back and we want two of them on one side for easier layouts:
  $while->set_attribute('rows',2);

  $self->connect($while, $body, 'false', 'false');

  if (defined $cont)
    {
    $cont = $self->add_block ($cont, $body);
    $self->connect($cont, $while);
    }
  else
    {
    $self->connect($body, $while);
    }

  my $joint = $self->add_joint();
  $self->connect($while, $joint, 'true', 'true');

  $self->{_cur} = $joint;

  ($joint, $body, $cont);
  }

1;
__END__