File Coverage

lib/Graph/Easy/As_txt.pm

Criterion	Covered	Total	%
statement	175	181	96.6
branch	90	96	93.7
condition	37	46	80.4
subroutine	11	11	100.0
pod	4	4	100.0
total	317	338	93.7

#############################################################################
# Output an Graph::Easy object as textual description
#

package Graph::Easy::As_txt;

$VERSION = '0.75';

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

package Graph::Easy;

use strict;
use warnings;

sub _as_txt
  {
  my ($self) = @_;

  # Convert the graph to a textual representation - does not need layout().
  $self->_assign_ranks();

  # generate the class attributes first
  my $txt = '';
  my $att =  $self->{att};
  for my $class (sort keys %$att)
    {

    my $out = $self->_remap_attributes(
     $class, $att->{$class}, {}, 'noquote', 'encode' );

    my $att = '';
    for my $atr (sort keys %$out)
      {
      # border is handled special below
      next if $atr =~ /^border/;
      $att .= "  $atr: $out->{$atr};\n";
      }

    # edges do not have a border
    if ($class !~ /^edge/)
      {
      my $border = $self->border_attribute($class) || '';

      # 'solid 1px #000000' =~ /^solid/;
      # 'solid 1px #000000' =~ /^solid 1px #000000/;
      $border = '' if $self->default_attribute($class,'border') =~ /^$border/;

      $att .= "  border: $border;\n" if $border ne '';
      }

    if ($att ne '')
      {
      # the following makes short, single definitions to fit on one line
      if ($att !~ /\n.*\n/ && length($att) < 40)
        {
        $att =~ s/\n/ /; $att =~ s/^  / /;
        }
      else
        {
        $att = "\n$att";
        }
      $txt .= "$class {$att}\n";
      }
    }

  $txt .= "\n" if $txt ne '';		# insert newline

  my @nodes = $self->sorted_nodes('name','id');

  my $count = 0;
  # output nodes with attributes first, sorted by their name
  foreach my $n (@nodes)
    {
    $n->{_p} = undef;			# mark as not yet processed
    my $att = $n->attributes_as_txt();
    if ($att ne '')
      {
      $n->{_p} = 1;			# mark as processed
      $count++;
      $txt .= $n->as_pure_txt() . $att . "\n";
      }
    }

  $txt .= "\n" if $count > 0;		# insert a newline

  # output groups first, with their nodes
  foreach my $gn (sort keys %{$self->{groups}})
    {
    my $group = $self->{groups}->{$gn};
    $txt .= $group->as_txt();		# marks nodes as processed if nec.
    $count++;
    }

  # XXX TODO:
  # Output all nodes with rank=0 first, and also follow their successors
  # What is left will then be done next, with rank=1 etc.
  # This output order let's us output node chains in compact form as:
  # [A]->[B]->[C]->[D]
  # [B]->[E]
  # instead of having:
  # [A]->[B]
  # [B]->[E]
  # [B]->[C] etc

  @nodes = $self->sorted_nodes('rank','name');
  foreach my $n (@nodes)
    {
    my @out = $n->sorted_successors();
    my $first = $n->as_pure_txt(); 		# [ A | B ]
    if ( defined $n->{autosplit} || ((@out == 0) && ( (scalar $n->predecessors() || 0) == 0)))
      {
      # single node without any connections (unless already output)
      next if exists $n->{autosplit} && !defined $n->{autosplit};
      $txt .= $first . "\n" unless defined $n->{_p};
      }

    $first = $n->_as_part_txt();		# [ A.0 ]
    # for all outgoing connections
    foreach my $other (@out)
      {
      # in case there exists more than one edge from $n --> $other
      my @edges = $n->edges_to($other);
      for my $edge (sort { $a->{id} <=> $b->{id} } @edges)
        {
        $txt .= $first . $edge->as_txt() . $other->_as_part_txt() . "\n";
        }
      }
    }

  foreach my $n (@nodes)
    {
    delete $n->{_p};			# clean up
    }

  $txt;
  }

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

package Graph::Easy::Group;

use strict;

sub as_txt
  {
  my $self = shift;

  my $n = '';
  if (!$self->isa('Graph::Easy::Group::Anon'))
    {
    $n = $self->{name};
    # quote special chars in name
    $n =~ s/([\[\]\(\)\{\}\#])/\\$1/g;
    $n = ' ' . $n;
    }

  my $txt = "($n";

  $n = $self->{nodes};

  $txt .= (keys %$n > 0 ? "\n" : ' ');
  for my $name ( sort keys %$n )
    {
    $n->{$name}->{_p} = 1;                              # mark as processed
    $txt .= '  ' . $n->{$name}->as_pure_txt() . "\n";
    }
  $txt .= ")" . $self->attributes_as_txt() . "\n\n";

  # insert all the edges of the group

  #
  $txt;
  }

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

package Graph::Easy::Node;

use strict;

sub attributes_as_txt
  {
  # return the attributes of this node as text description
  my ($self, $remap) = @_;

  # nodes that were autosplit
  if (exists $self->{autosplit})
    {
    # other nodes are invisible in as_txt:
    return '' unless defined $self->{autosplit};
    # the first one might have had a label set
    }

  my $att = '';
  my $class = $self->class();
  my $g = $self->{graph};

  # XXX TODO: remove atttributes that are simple the default attributes

  my $attributes = $self->{att};
  if (exists $self->{autosplit})
    {
    # for the first node in a row of autosplit nodes, we need to create
    # the correct attributes, e.g. "silver|red|" instead of just silver:
    my $basename = $self->{autosplit_basename};
    $attributes = { };

    my $parts = $self->{autosplit_parts};
    # gather all possible attribute names, otherwise an attribute set
    # on only one part (like via "color: |red;" would not show up:
    my $names = {};
    for my $child ($self, @$parts)
      {
      for my $k (sort keys %{$child->{att}})
        {
        $names->{$k} = undef;
        }
      }

    for my $k (sort keys %$names)
      {
      next if $k eq 'basename';
      my $val = $self->{att}->{$k};
      $val = '' unless defined $val;
      my $first = $val; my $not_equal = 0;
      $val .= '|';
      for my $child (@$parts)
        {
        # only consider our own autosplit parts (check should not be nec.)
#        next if !exists $child->{autosplit_basename} ||
#                        $child->{autosplit_basename} ne $basename;

        my $v = $child->{att}->{$k}; $v = '' if !defined $v;
        $not_equal ++ if $v ne $first;
        $val .= $v . '|';
        }
      # all parts equal, so do "red|red|red" => "red"
      $val = $first if $not_equal == 0;

      $val =~ s/\|+\z/\|/;				# "silver|||" => "silver|"
      $val =~ s/\|\z// if $val =~ /\|.*\|/;		# "silver|" => "silver|"
      							# but "red|blue|" => "red|blue"
      $attributes->{$k} = $val unless $val eq '|';	# skip '|'
      }
    $attributes->{basename} = $self->{att}->{basename} if defined $self->{att}->{basename};
    }

  my $new = $g->_remap_attributes( $self, $attributes, $remap, 'noquote', 'encode' );

  # For nodes, we do not output their group attribute, since they simple appear
  # at the right place in the txt:
  delete $new->{group};

  # for groups inside groups, insert their group attribute
  $new->{group} = $self->{group}->{name}
    if $self->isa('Graph::Easy::Group') && exists $self->{group};

  if (defined $self->{origin})
    {
    $new->{origin} = $self->{origin}->{name};
    $new->{offset} = join(',', $self->offset());
    }

  # shorten output for multi-celled nodes
  # for "rows: 2;" still output "rows: 2;", because it is shorter
  if (exists $new->{columns})
    {
    $new->{size} = ($new->{columns}||1) . ',' . ($new->{rows}||1);
    delete $new->{rows};
    delete $new->{columns};
    # don't output the default size
    delete $new->{size} if $new->{size} eq '1,1';
    }

  for my $atr (sort keys %$new)
    {
    next if $atr =~ /^border/;                  # handled special

    $att .= "$atr: $new->{$atr}; ";
    }

  if (!$self->isa_cell())
    {
    my $border;
    if (!exists $self->{autosplit})
      {
      $border = $self->border_attribute();
      }
    else
      {
      $border = Graph::Easy::_border_attribute(
	$attributes->{borderstyle}||'',
	$attributes->{borderwidth}||'',
	$attributes->{bordercolor}||'');
      }

    # XXX TODO: should do this for all attributes, not only for border
    # XXX TODO: this seems wrong anyway

    # don't include default border
    $border = '' if ref $g && $g->attribute($class,'border') eq $border;
    $att .= "border: $border; " if $border ne '';
    }

  # if we have a subclass, we probably need to include it
  my $c = '';
  $c = $1 if $class =~ /\.(\w+)/;

  # but we do not need to include it if our group has a nodeclass attribute
  $c = '' if ref($self->{group}) && $self->{group}->attribute('nodeclass') eq $c;

  # include our subclass as attribute
  $att .= "class: $c; " if $c ne '' && $c ne 'anon';

  # generate attribute text if nec.
  $att = ' { ' . $att . '}' if $att ne '';

  $att;
  }

sub _as_part_txt
  {
  # for edges, we need the name of the part of the first part, not the entire
  # autosplit text
  my $self = shift;

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

  # quote special chars in name
  $name =~ s/([\[\]\|\{\}\#])/\\$1/g;

  '[ ' .  $name . ' ]';
  }

sub as_pure_txt
  {
  my $self = shift;

  if (exists $self->{autosplit} && defined $self->{autosplit})
    {
    my $name = $self->{autosplit};

    # quote special chars in name (but not |)
    $name =~ s/([\[\]\{\}\#])/\\$1/g;

    return '[ '. $name .' ]'
    }

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

  # quote special chars in name
  $name =~ s/([\[\]\|\{\}\#])/\\$1/g;

  '[ ' .  $name . ' ]';
  }

sub as_txt
  {
  my $self = shift;

  if (exists $self->{autosplit})
    {
    return '' unless defined $self->{autosplit};
    my $name = $self->{autosplit};
    # quote special chars in name (but not |)
    $name =~ s/([\[\]\{\}\#])/\\$1/g;
    return '[ ' . $name . ' ]'
    }

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

  # quote special chars in name
  $name =~ s/([\[\]\|\{\}\#])/\\$1/g;

  '[ ' .  $name . ' ]' . $self->attributes_as_txt();
  }

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

package Graph::Easy::Edge;

my $styles = {
  solid => '--',
  dotted => '..',
  double => '==',
  'double-dash' => '= ',
  dashed => '- ',
  'dot-dash' => '.-',
  'dot-dot-dash' => '..-',
  wave => '~~',
  };

sub _as_txt
  {
  my $self = shift;

  # '- Name ' or ''
  my $n = $self->{att}->{label}; $n = '' unless defined $n;

  my $left = ' '; $left = ' <' if $self->{bidirectional};
  my $right = '> '; $right = ' ' if $self->{undirected};

  my $s = $self->style() || 'solid';

  my $style = '--';

  # suppress border on edges
  my $suppress = { all => { label => undef } };
  if ($s =~ /^(bold|bold-dash|broad|wide|invisible)\z/)
    {
    # output "--> { style: XXX; }"
    $style = '--';
    }
  else
    {
    # output "-->" or "..>" etc
    $suppress->{all}->{style} = undef;

    $style = $styles->{ $s };
    if (!defined $style)
      {
      require Carp;
      Carp::confess ("Unknown edge style '$s'\n");
      }
    }

  $n = $style . " $n " if $n ne '';

  # make " -  " into " - -  "
  $style = $style . $style if $self->{undirected} && substr($style,1,1) eq ' ';

  # ' - Name -->' or ' --> ' or ' -- '
  my $a = $self->attributes_as_txt($suppress) . ' '; $a =~ s/^\s//;
  $left . $n . $style . $right . $a;
  }

1;
__END__