File Coverage

blib/lib/Graph/Writer/Dot.pm

Criterion	Covered	Total	%
statement	66	75	88.0
branch	11	14	78.5
condition	5	6	83.3
subroutine	7	7	100.0
pod			n/a
total	89	102	87.2

#
# Graph::Writer::Dot - write a directed graph out in Dot format
#
package Graph::Writer::Dot;
$Graph::Writer::Dot::VERSION = '2.09';
use 5.006;
use strict;
use warnings;

use parent 'Graph::Writer';

#-----------------------------------------------------------------------
# List of valid dot attributes for the entire graph, per node,
# and per edge. You can set other attributes, but they won't get
# written out.
#-----------------------------------------------------------------------
my %valid_attributes =
(
    graph => [qw(bb bgcolor center clusterrank color comment compound
		 concentrate Damping defaultlist dim dpi epsilon fontcolor
		 fontname fontpath fontsize label labeljust labelloc layers
		 layersep lp margin maxiter mclimit mindist mode model nodesep
		 nojustify normalize nslimit nslimit1 ordering ordering
		 orientation outputorder overlap pack packmode page pagedir
		 quantum rank rankdir ranksep ratio remincross resolution
		 root rotate samplepoints searchsize sep showboxes size
		 splines start stylesheet target truecolor viewport voro_margin)],

    node  => [qw(bottomlabel color comment distortion fillcolor fixedsize
		 fontcolor fontname fontsize group height width label layer
		 margin nojustify orientation peripheries pin pos rects regular
		 root shape shapefile showboxes sides skew style target
		 tooltip toplabel URL vertices width z)],

    edge  => [qw(arrowhead arrowsize arrowtail color comment constraint decorate
		 dir fontcolor fontname fontsize headURL headclip headhref
		 headlabel headport headtarget headtooltip href id label
		 labelangle labeldistance labelfloat labelfontcolor labelfontname
		 labelfontsize layer len lhead lp ltail minlen nojustify
		 pos samehead sametail showboxes style tailURL tailclip
		 tailhref taillabel tailport tailtarget tailtooltip target
		 tooltip weight)],
);

#=======================================================================
#
# _init()
#
# class-specific initialisation. There isn't any here, but it's
# kept as a place-holder.
#
#=======================================================================
sub _init
{
    my $self = shift;
    my %param = @_;

    $self->SUPER::_init();
    $self->{_cluster} = $param{cluster};
}

#=======================================================================
#
# _write_graph()
#
# The private method which actually does the writing out in
# dot format.
#
# This is called from the public method, write_graph(), which is
# found in Graph::Writer.
#
#=======================================================================
sub _write_graph
{
    my $self  = shift;
    my $graph = shift;
    my $FILE  = shift;

    my $v;
    my $from;
    my $to;
    my $gn;
    my $attrref;
    my @keys;


    #-------------------------------------------------------------------
    # If the graph has a 'name' attribute, then we use that for the
    # name of the digraph instance. Else it's just 'g'.
    #-------------------------------------------------------------------
    $gn = $graph->has_graph_attribute('name') ? $graph->get_graph_attribute('name') : 'g';
    print $FILE "digraph $gn\n{\n";

    #-------------------------------------------------------------------
    # Dump out any overall attributes of the graph
    #-------------------------------------------------------------------
    $attrref = $graph->get_graph_attributes();
    @keys = grep(exists $attrref->{$_}, @{$valid_attributes{'graph'}});
    if (@keys > 0)
    {
        print $FILE "  /* graph attributes */\n";
        foreach my $a (@keys)
        {
            print $FILE "  $a = \"", $attrref->{$a}, "\";\n";
        }
    }

    #-------------------------------------------------------------------
    # Generate a list of nodes, with attributes for those that have any.
    #-------------------------------------------------------------------
    print $FILE "\n  /* list of nodes */\n";
    foreach $v (sort $graph->vertices)
    {
        print $FILE "  \"$v\"";
        $attrref = $graph->get_vertex_attributes($v);
        @keys = grep(exists $attrref->{$_}, @{$valid_attributes{'node'}});
        if (@keys > 0)
        {
            print $FILE " [", join(',',
                              map { "$_=\"".$attrref->{$_}."\"" } @keys), "]";
        }
        print $FILE ";\n";
    }

    if ($self->{_cluster} && grep { $_ eq $self->{_cluster} } @{$valid_attributes{'node'}}) {
        #-------------------------------------------------------------------
        # Generate a list of subgraphs based on the attribute value.
        #-------------------------------------------------------------------
        print $FILE "\n  /* list of subgraphs */\n";
        my %cluster = ();
        foreach my $v (sort $graph->vertices) {
            my $attrs = $graph->get_vertex_attributes($v);
            next unless $attrs && $attrs->{$self->{_cluster}};
            my $attr_value = $attrs->{$self->{_cluster}};
            $cluster{$attr_value} = [] unless exists $cluster{$attr_value};
            push @{ $cluster{$attr_value} }, $v;
        }
        foreach my $attr_value (sort keys %cluster) {
            print $FILE "  subgraph \"cluster_$attr_value\" {\n";
            print $FILE "    label = \"$attr_value\";\n";
            foreach my $node (@{ $cluster{$attr_value} }) {
                print $FILE "    node [label=\"$node\"] \"$node\";\n";
            }
            print $FILE "  }\n";
        }
    }

    #-------------------------------------------------------------------
    # Generate a list of edges, along with any attributes
    #-------------------------------------------------------------------
    print $FILE "\n  /* list of edges */\n";
    foreach my $edge (sort _by_vertex $graph->edges)
    {
        ($from, $to) = @$edge;
        print $FILE "  \"$from\" -> \"$to\"";
        $attrref = $graph->get_edge_attributes($from, $to);
        @keys = grep(exists $attrref->{$_}, @{$valid_attributes{'edge'}});
        if (@keys > 0)
        {
            print $FILE " [", join(',',
                              map { "$_ = \"".$attrref->{$_}."\"" } @keys), "]";
        }
        print $FILE ";\n";
    }

    #-------------------------------------------------------------------
    # close off the digraph instance
    #-------------------------------------------------------------------
    print $FILE "}\n";

    return 1;
}


sub _by_vertex
{
    return $a->[0].$a->[1] cmp $b->[0].$b->[1];
}


1;

__END__