add Graph::GEXF while it's not on CPAN

Signed-off-by: franck cuny <franck@lumberjaph.net>

1 files changed, 168 insertions, 0 deletions

diff --git a/lib/Graph/GEXF/Role/XML.pm b/lib/Graph/GEXF/Role/XML.pm
new file mode 100644
index 0000000..cf12170
--- /dev/null
+++ b/lib/Graph/GEXF/Role/XML.pm
@@ -0,0 +1,168 @@
+package Graph::GEXF::Role::XML;
+
+use Moose::Role;
+
+use XML::Simple;
+
+has gexf_ns => (
+    is      => 'ro',
+    isa     => 'Str',
+    default => 'http://www.gexf.net/1.2draft'
+);
+
+has gexf_version => (
+    is      => 'ro',
+    isa     => 'Num',
+    default => '1.2'
+);
+
+sub to_xml {
+    my $self = shift;
+
+    my $graph = $self->_init_graph();
+
+    foreach (qw/node edge/) {
+        $self->_add_attributes( $graph, $_ );
+    }
+
+    $self->_add_nodes($graph);
+
+    my $xml_out = XMLout($graph, AttrIndent => 1, keepRoot => 1);
+    $xml_out;
+}
+
+sub _add_attributes {
+    my ($self, $graph, $type) = @_;
+
+    my $list_attr = 'attributes_' . $type . '_list';
+    my $get_attr  = 'get_' . $type . '_attribute';
+
+    my $attributes;
+    $attributes->{class} = $type;
+
+    foreach my $attr_id ($self->$list_attr) {
+        my $attribute = $self->$get_attr($attr_id);
+        push @{$attributes->{attribute}},
+          { id      => $attribute->{id},
+            type    => $attribute->{type},
+            title   => $attribute->{title},
+            default => $attribute->{default},
+          };
+    }
+
+    push @{$graph->{gexf}->{graph}->{attributes}}, $attributes;
+}
+
+sub _init_graph {
+    my $self = shift;
+
+    # XXX this need some refactoring
+    return {
+        gexf => {
+            xmlns   => $self->gexf_ns,
+            version => $self->gexf_version,
+            meta    => {creator => ['Graph::GEXF']},
+            graph   => {
+                mode            => $self->graph_mode,
+                defaultedgetype => $self->edge_type,
+            }
+        }
+    };
+}
+
+sub _add_nodes {
+    my ( $self, $graph ) = @_;
+
+    my $edges_id = 0;
+
+    foreach my $node_id ( $self->all_nodes ) {
+        my $node = $self->get_node($node_id);
+        my ( $node_desc, $edges ) = $self->_create_node($node);
+        push @{ $graph->{gexf}->{graph}->{nodes}->{node} }, $node_desc;
+        foreach my $edge (@$edges) {
+            push @{ $graph->{gexf}->{graph}->{edges}->{edge} }, $edge;
+        }
+    }
+}
+
+sub _create_node {
+    my ( $self, $node ) = @_;
+
+    my $label = $node->label || $node->id;
+
+    my $node_desc = { id => $node->id, label => $label };
+
+    foreach my $attr_id ( $node->attributes_node_list ) {
+        my $attr = $node->get_node_attribute($attr_id);
+        push @{ $node_desc->{attvalues}->{attvalue} },
+          { for => $attr->{id}, value => $attr->{value} };
+    }
+
+    $self->_add_visualizations_elements($node, $node_desc);
+
+    my @edges =
+      map { $self->_create_edge( $node->get_edge($_) ) } $node->all_edges;
+
+    return ($node_desc, \@edges);
+}
+
+sub _create_edge {
+    my ( $self, $edge ) = @_;
+    my $edge_desc = {
+        id     => $edge->id,
+        source => $edge->source,
+        target => $edge->target,
+        weight => $edge->weight,
+    };
+
+    $self->_add_shape($edge, $edge_desc);
+    
+    return $edge_desc;
+}
+
+sub _add_visualizations_elements {
+    my ( $self, $node, $node_desc ) = @_;
+
+    return unless $self->has_visualization;
+
+    foreach (qw/colors size shape position/){
+        my $method = "_add_$_";
+        $self->$method($node, $node_desc);
+    }
+}
+
+sub _add_colors {
+    my ( $self, $element, $element_desc ) = @_;
+
+    return unless $element->has_colors;
+    push @{ $element_desc->{'viz:color'} },
+      $self->_add_viz_elements( $element, qw/r g b a/ );
+}
+
+sub _add_size {
+    my ($self, $element, $element_desc) = @_;
+    push @{$element_desc->{'viz:size'}}, {value => $element->size};
+}
+
+sub _add_shape {
+    my ($self, $element, $element_desc) = @_;
+    push @{$element_desc->{'viz:shape'}}, {value => $element->shape};
+}
+
+sub _add_position {
+    my ($self, $element, $element_desc) = @_;
+
+    return unless $element->has_position;
+    push @{ $element_desc->{'viz:position'} },
+      $self->_add_viz_elements( $element, qw/x y z/ );
+}
+
+sub _add_viz_elements {
+    my ( $self, $element, @attrs ) = @_;
+    my %hash = map { $_ => $element->$_ } @attrs;
+    \%hash;
+}
+
+no Moose::Role;
+
+1;