File Coverage

blib/lib/Graph/Writer/daVinci.pm
Criterion Covered Total %
statement 55 82 67.0
branch 10 18 55.5
condition n/a
subroutine 6 7 85.7
pod n/a
total 71 107 66.3


line stmt bran cond sub pod time code
1             #
2             # Graph::Writer::daVinci - write a directed graph out in daVinci format
3             #
4             package Graph::Writer::daVinci;
5             $Graph::Writer::daVinci::VERSION = '2.08';
6 1     1   587 use 5.006;
  1         3  
7 1     1   5 use strict;
  1         1  
  1         21  
8 1     1   4 use warnings;
  1         2  
  1         23  
9              
10 1     1   5 use parent 'Graph::Writer';
  1         1  
  1         6  
11              
12             #-----------------------------------------------------------------------
13             # List of valid daVinci attributes for the entire graph, per node,
14             # and per edge. You can set other attributes, but they won't get
15             # written out.
16             #-----------------------------------------------------------------------
17             my %valid_attributes =
18             (
19             node => [qw(OBJECT FONTFAMILY FONTSTYLE COLOR CCOLOR _GO _CGO
20             ICONFILE CICONFILE HIDDEN BORDER)],
21              
22             edge => [qw(EDGECOLOR EDGEPATTERN _DIR HEAD)],
23             );
24              
25             #=======================================================================
26             #
27             # _write_graph()
28             #
29             # The private method which actually does the writing out in
30             # daVinci format.
31             #
32             # This is called from the public method, write_graph(), which is
33             # found in Graph::Writer.
34             #
35             #=======================================================================
36             sub _write_graph
37             {
38 1     1   4 my $self = shift;
39 1         2 my $graph = shift;
40 1         2 my $FILE = shift;
41              
42 1         2 my $v;
43             my $from;
44 0         0 my $to;
45 0         0 my $gn;
46 0         0 my $aref;
47 0         0 my @keys;
48 0         0 my (@nodes, @edges);
49 1         2 my %done = ();
50 1         2 my $node;
51              
52              
53 1         6 @nodes = sort $graph->source_vertices;
54 1 50       627 if (@nodes == 0)
55             {
56 0         0 die "expecting source vertices!\n";
57             }
58              
59 1         4 print $FILE "[\n";
60 1         5 while (@nodes > 0)
61             {
62 1         2 $node = shift @nodes;
63 1         5 $self->_dump_node($graph, $FILE, $node, \%done, 1);
64 1 50       5 print $FILE ",\n" if @nodes > 0;
65             }
66 1         3 print $FILE "\n]\n";
67              
68 1         5 return 1;
69              
70             #-------------------------------------------------------------------
71             # Generate a list of edges, along with any attributes
72             #-------------------------------------------------------------------
73 0         0 print $FILE "\n /* list of edges */\n";
74 0         0 @edges = sort _by_vertex $graph->edges;
75 0         0 for (my $i = 0; $i < @edges; $i++)
76             {
77 0         0 ($from, $to) = @{ $edges[$i] };
  0         0  
78 0         0 print $FILE " $from -> $to";
79 0         0 $aref = $graph->get_graph_attributes($from, $to);
80 0         0 @keys = grep(exists $aref->{$_}, @{$valid_attributes{'edge'}});
  0         0  
81 0 0       0 if (@keys > 0)
82             {
83             print $FILE " [", join(',',
84 0         0 map { "$_ = \"".$aref->{$_}."\"" } @keys), "]";
  0         0  
85             }
86 0 0       0 print $FILE ", " if $i < @edges - 1;
87             }
88              
89 0         0 return 1;
90             }
91              
92              
93             sub _by_vertex
94             {
95 0     0   0 return $a->[0].$a->[1] cmp $b->[0].$b->[1];
96             }
97              
98              
99             #=======================================================================
100             #
101             # _dump_node
102             #
103             # Write out a node, using a reference if we've already written it.
104             # If there are any outgoing edges, we dump them out, recursively
105             # calling ourself to dump the nodes at the other end of each edge.
106             #
107             #=======================================================================
108             sub _dump_node
109             {
110 8     8   16 my ($self, $graph, $FILE, $node, $doneref, $depth) = @_;
111 8         11 my $aref;
112             my @keys;
113 0         0 my @children;
114 0         0 my $child;
115 8         10 local $_;
116              
117              
118 8 100       17 if (exists $doneref->{$node})
119             {
120 3         14 print $FILE ' ' x (2 * $depth), "r(\"Node $node\")";
121             }
122             else
123             {
124 5         16 print $FILE ' ' x (2 * $depth), "l(\"Node $node\", n(\"\"";
125 5         13 $aref = $graph->get_vertex_attributes($node);
126 5         397 @keys = grep(exists $aref->{$_}, @{$valid_attributes{'node'}});
  5         21  
127 5 50       12 if (@keys > 0)
128             {
129             print $FILE ", [", join(', ',
130 0         0 map { "a(\"$_\", \"".$aref->{$_}."\")" } @keys), "]";
  0         0  
131             }
132             else
133             {
134 5         8 print $FILE ", []";
135             }
136              
137 5         9 $doneref->{$node} = 1;
138              
139 5         16 @children = sort $graph->successors($node);
140 5 100       419 if (@children == 0)
141             {
142 1         3 print $FILE ", []";
143             }
144             else
145             {
146 4         13 print $FILE ",\n", ' ' x (2 * $depth + 1), "[\n";
147 4         11 while (@children > 0)
148             {
149 7         12 $child = shift @children;
150 7         23 print $FILE ' ' x (2 * $depth + 2),
151             "l(\"Edge ${node}->$child\", e(\"\", [";
152              
153             # write out any attributes of the edge
154 7         18 $aref = $graph->get_edge_attributes($node, $child);
155 7         2035 @keys = grep(exists $aref->{$_}, @{$valid_attributes{'edge'}});
  7         22  
156 7 50       19 if (@keys > 0)
157             {
158             print $FILE join(', ',
159 0         0 map { "a(\"$_\", \"".$aref->{$_}."\")" } @keys);
  0         0  
160             }
161              
162 7         11 print $FILE "],\n";
163 7         34 $self->_dump_node($graph, $FILE, $child, $doneref, $depth+2);
164 7         11 print $FILE "))";
165 7 100       26 print $FILE ",\n" if @children > 0;
166             }
167 4         9 print $FILE ' ' x (2 * $depth + 1), "]";
168             }
169 5         15 print $FILE "))";
170             }
171             }
172              
173             1;
174              
175             __END__