File Coverage

lib/Graph/Easy/As_graphml.pm

Criterion	Covered	Total	%
statement	143	151	94.7
branch	28	36	77.7
condition	9	11	81.8
subroutine	15	15	100.0
pod	1	3	33.3
total	196	216	90.7

#############################################################################
# Output an Graph::Easy object as GraphML text
#
#############################################################################

package Graph::Easy::As_graphml;

$VERSION = '0.75';

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

package Graph::Easy;

use strict;
use warnings;

use Graph::Easy::Attributes;

# map the Graph::Easy attribute types to a GraphML name:
my $attr_type_to_name =
  {
  ATTR_STRING()	=> 'string',
  ATTR_COLOR()	=> 'string',
  ATTR_ANGLE()	=> 'double',
  ATTR_PORT()	=> 'string',
  ATTR_UINT()	=> 'integer',
  ATTR_URL()	=> 'string',

  ATTR_LIST()	=> 'string',
  ATTR_LCTEXT()	=> 'string',
  ATTR_TEXT()	=> 'string',
  };

sub _graphml_attr_keys
  {
  my ($self, $tpl, $tpl_no_default, $class, $att, $ids, $id) = @_;

  my $base_class = $class; $base_class =~ s/\..*//;
  $base_class = 'graph' if $base_class =~ /group/;
  $ids->{$base_class} = {} unless ref $ids->{$base_class};

  my $txt = '';
  for my $name (sort keys %$att)
    {
    my $entry = $self->_attribute_entry($class,$name);
    # get a fresh template
    my $t = $tpl;
    $t = $tpl_no_default unless defined $entry->[ ATTR_DEFAULT_SLOT ];

    # only keep it once
    next if exists $ids->{$base_class}->{$name};

    $t =~ s/##id##/$$id/;

    # node.foo => node, group.bar => graph
    $t =~ s/##class##/$base_class/;
    $t =~ s/##name##/$name/;
    $t =~ s/##type##/$attr_type_to_name->{ $entry->[ ATTR_TYPE_SLOT ] || ATTR_COLOR }/eg;

    # will only be there and thus replaced if we have a default
    if ($t =~ /##default##/)
      {
      my $def = $entry->[ ATTR_DEFAULT_SLOT ];
      # not a simple value?
      $def = $self->default_attribute($name) if ref $def;
      $t =~ s/##default##/$def/;
      }

    # remember name => ID
    $ids->{$base_class}->{$name} = $$id; $$id++;
    # append the definition
    $txt .= $t;
    }
  $txt;
  }

# yED example:

#
#
#
#
#
#    1
#
#
#

use Graph::Easy::Util qw(ord_values);

sub _as_graphml
  {
  my $self = shift;

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

  $args->{format} = 'graph-easy' unless defined $args->{format};

  if ($args->{format} !~ /^(graph-easy|Graph::Easy|yED)\z/i)
    {
    return $self->error("Format '$args->{format}' not understood by as_graphml.");
    }
  my $format = $args->{format};

  # Convert the graph to a textual representation - does not need layout().

  my $schema = "http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd";
  $schema = "http://www.yworks.com/xml/schema/graphml/1.0/ygraphml.xsd" if $format eq 'yED';
  my $y_schema = '';
  $y_schema = "\n    xmlns:y=\"http://www.yworks.com/xml/graphml\"" if $format eq 'yED';

  my $txt = <


    xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"##Y##
    xsi:schemaLocation="http://graphml.graphdrawing.org/xmlns
     ##SCHEMA##">



EOF
;

  $txt =~ s/##DATE##/scalar localtime()/e;
  $txt =~ s/##VERSION##/$Graph::Easy::VERSION/;
  $txt =~ s/##SCHEMA##/$schema/;
  $txt =~ s/##Y##/$y_schema/;

  #
  #   yellow
  #
  #

  # First gather all possible attributes, then add defines for them. This
  # avoids lengthy re-definitions of attributes that aren't used:

  my %keys;

  my $tpl = '  '
      ."\n    ##default##\n"
      ."  \n";
  my $tpl_no_default = '  '."\n";

  # for yED:
  #
  #
  #
  #
  #

  # we need to remember the mapping between attribute name and ID:
  my $ids = {};
  my $id = 'd0';

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

    $txt .=
	$self->_graphml_attr_keys( $tpl, $tpl_no_default, $class, $att, $ids, \$id);

    }

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

  ###########################################################################
  # now the attributes on the objects:
  for my $o (@nodes, ord_values ( $self->{edges} ))
    {
    $txt .=
	$self->_graphml_attr_keys( $tpl, $tpl_no_default, $o->class(),
				   $o->raw_attributes(), $ids, \$id);
    }
  $txt .= "\n" unless $id eq 'd0';

  my $indent = '  ';
  $txt .= $indent . '\n";

  # output graph attributes:
  $txt .= $self->_attributes_as_graphml($self,'  ',$ids->{graph});

  # output groups recursively
  my @groups = $self->groups_within(0);
  foreach my $g (@groups)
    {
    $txt .= $g->as_graphml($indent.'  ',$ids);			# marks nodes as processed if nec.
    }

  $indent = '    ';
  foreach my $n (@nodes)
    {
    next if $n->{group};				# already done in a group
    $txt .= $n->as_graphml($indent,$ids);		#
    }

  $txt .= "\n";

  foreach my $n (@nodes)
    {
    next if $n->{group};				# already done in a group

    my @out = $n->sorted_successors();
    # 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 .= $edge->as_graphml($indent,$ids);	#
        }
      }
    }

  $txt .= "  \n\n";
  $txt;
  }

sub _safe_xml
  {
  # make a text XML safe
  my ($self,$txt) = @_;

  $txt =~ s/&/&/g;			# quote &
  $txt =~ s/>/>/g;			# quote >
  $txt =~ s/
  $txt =~ s/"/"/g;			# quote "
  $txt =~ s/'/'/g;			# quote '
  $txt =~ s/\\\\/\\/g;			# "\\" to "\"

  $txt;
  }

sub _attributes_as_graphml
  {
  # output the attributes of an object
  my ($graph, $self, $indent, $ids) = @_;

  my $tpl = "$indent  ##value##\n";
  my $att = $self->get_attributes();
  my $txt = '';
  for my $n (sort keys %$att)
    {
    next unless exists $ids->{$n};
    my $def = $self->default_attribute($n);
    next if defined $def && $def eq $att->{$n};
    my $t = $tpl;
    $t =~ s/##id##/$ids->{$n}/;
    $t =~ s/##value##/$graph->_safe_xml($att->{$n})/e;
    $txt .= $t;
    }
  $txt;
  }

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

package Graph::Easy::Group;

use strict;

use Graph::Easy::Util qw(ord_values);

sub as_graphml
  {
  my ($self, $indent, $ids) = @_;

  my $txt = $indent . '
273
	$self->{graph}->type() . "\">\n";
  $txt .= $self->{graph}->_attributes_as_graphml($self, $indent, $ids->{graph});

  foreach my $n (ord_values ( $self->{nodes} ))
    {
    my @out = $n->sorted_successors();

    $txt .= $n->as_graphml($indent.'  ', $ids); 		#

    # 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 .= $edge->as_graphml($indent.'  ',$ids);
        }
      $txt .= "\n" if @edges > 0;
      }
    }

  # output groups recursively
  my @groups = $self->groups_within(0);
  foreach my $g (@groups)
    {
    $txt .= $g->_as_graphml($indent.'  ',$ids);		# marks nodes as processed if nec.
    }

  # XXX TODO: edges from/to this group

  # close this group
  $txt .= $indent . "";

  $txt;
  }

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

package Graph::Easy::Node;

use strict;

sub as_graphml
  {
  my ($self, $indent, $ids) = @_;

  my $g = $self->{graph};
  my $txt = $indent . '\n";

  $txt .= $g->_attributes_as_graphml($self, $indent, $ids->{node});

  $txt .= "$indent\n";

  return $txt;
  }

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

package Graph::Easy::Edge;

use strict;

sub as_graphml
  {
  my ($self, $indent, $ids) = @_;

  my $g = $self->{graph};
  my $txt = $indent . '
342
		     '" target="' . $g->_safe_xml($self->{to}->{name}) . "\">\n";

  $txt .= $g->_attributes_as_graphml($self, $indent, $ids->{edge});

  $txt .= "$indent\n";

  $txt;
  }

1;
__END__