File Coverage

blib/lib/Graph/Writer/VCG.pm
Criterion Covered Total %
statement 51 60 85.0
branch 3 6 50.0
condition 0 6 0.0
subroutine 10 10 100.0
pod n/a
total 64 82 78.0


line stmt bran cond sub pod time code
1             #
2             # Graph::Writer::VCG - write a directed graph out in VCG format
3             #
4             package Graph::Writer::VCG;
5             $Graph::Writer::VCG::VERSION = '2.08';
6 1     1   605 use 5.006;
  1         3  
7 1     1   5 use strict;
  1         1  
  1         20  
8 1     1   5 use warnings;
  1         1  
  1         25  
9              
10 1     1   4 use parent 'Graph::Writer';
  1         2  
  1         5  
11              
12             #-----------------------------------------------------------------------
13             # Attribute type information
14             #-----------------------------------------------------------------------
15 1     1   53 use constant VCG_ATTR_TYPE_INTEGER => 1;
  1         1  
  1         77  
16 1     1   5 use constant VCG_ATTR_TYPE_STRING => 2;
  1         1  
  1         72  
17 1     1   5 use constant VCG_ATTR_TYPE_FLOAT => 3;
  1         2  
  1         1040  
18              
19             my $enum_color = [qw(aquamarine black blue cyan darkblue darkcyan darkgreen
20             darkgrey darkmagenta darkred darkyellow gold green khaki
21             lightblue lightcyan lightgreen lightgrey lightmagenta
22             lightred lightyellow lilac magenta orange orchid pink
23             purple red turquoise white yellow yellowgreen)];
24             my $enum_yes_no = [qw(yes no)];
25             my $enum_textmode = [qw(center left_justify right_justify)];
26             my $enum_shape = [qw(box rhomb ellipse triangle)];
27             my $enum_arrowstyle = [qw(none line solid)];
28              
29             my %common_attrs =
30             (
31             label => VCG_ATTR_TYPE_STRING,
32             color => $enum_color,
33             textcolor => $enum_color,
34             );
35              
36              
37             #-----------------------------------------------------------------------
38             # List of valid dot attributes for the entire graph, per node,
39             # and per edge. You can set other attributes, but they won't get
40             # written out.
41             #-----------------------------------------------------------------------
42             my %valid_attributes =
43             (
44             graph => {
45              
46             %common_attrs,
47              
48             title => VCG_ATTR_TYPE_STRING,
49             info1 => VCG_ATTR_TYPE_STRING,
50             info2 => VCG_ATTR_TYPE_STRING,
51             info3 => VCG_ATTR_TYPE_STRING,
52             bordercolor => $enum_color,
53             width => VCG_ATTR_TYPE_INTEGER,
54             height => VCG_ATTR_TYPE_INTEGER,
55             borderwidth => VCG_ATTR_TYPE_INTEGER,
56             x => VCG_ATTR_TYPE_INTEGER,
57             y => VCG_ATTR_TYPE_INTEGER,
58             # loc
59             folding => VCG_ATTR_TYPE_INTEGER,
60             scaling => VCG_ATTR_TYPE_FLOAT,
61             shrink => VCG_ATTR_TYPE_INTEGER,
62             stretch => VCG_ATTR_TYPE_INTEGER,
63             textmode => $enum_textmode,
64             shape => $enum_shape,
65             level => VCG_ATTR_TYPE_INTEGER,
66             vertical_order => VCG_ATTR_TYPE_INTEGER,
67             horizontal_order => VCG_ATTR_TYPE_INTEGER,
68             status => [qw(black grey white)],
69             xmax => VCG_ATTR_TYPE_INTEGER,
70             ymax => VCG_ATTR_TYPE_INTEGER,
71             xbase => VCG_ATTR_TYPE_INTEGER,
72             ybase => VCG_ATTR_TYPE_INTEGER,
73             xspace => VCG_ATTR_TYPE_INTEGER,
74             xlspace => VCG_ATTR_TYPE_INTEGER,
75             yspace => VCG_ATTR_TYPE_INTEGER,
76             xraster => VCG_ATTR_TYPE_INTEGER,
77             xlraster => VCG_ATTR_TYPE_INTEGER,
78             invisble => VCG_ATTR_TYPE_INTEGER,
79             hidden => VCG_ATTR_TYPE_INTEGER,
80             # classname
81             # colorentry
82             # infoname
83             layoutalgorithm => [qw(tree maxdepth mindepth maxdepthslow
84             mindepthslow maxdegree mindegree
85             maxindegree minindegree maxoutdegree
86             minoutdegree minbackward dfs)],
87             layout_downfactor => VCG_ATTR_TYPE_INTEGER,
88             layout_upfactor => VCG_ATTR_TYPE_INTEGER,
89             layout_nearfactor => VCG_ATTR_TYPE_INTEGER,
90             splinefactor => VCG_ATTR_TYPE_INTEGER,
91             late_edge_labels => $enum_yes_no,
92             display_edge_labels => $enum_yes_no,
93             dirty_edge_labels => $enum_yes_no,
94             finetuning => $enum_yes_no,
95             ignoresingles => $enum_yes_no,
96             straight_phase => $enum_yes_no,
97             priority_phase => $enum_yes_no,
98             manhattan_edges => $enum_yes_no,
99             smanhattan_edges => $enum_yes_no,
100             nearedges => $enum_yes_no,
101             orientation => [qw(top_to_bottom bottom_to_top
102             left_to_right right_to_left)],
103             node_alignment => [qw(bottom top center)],
104             port_sharing => $enum_yes_no,
105             arrowmode => [qw(fixed free)],
106             spreadlevel => VCG_ATTR_TYPE_INTEGER,
107             treefactor => VCG_ATTR_TYPE_FLOAT,
108             crossingphase2 => $enum_yes_no,
109             crossingoptimization=> $enum_yes_no,
110             crossingweight => [qw(bary median barymedian medianbary)],
111             view => [qw(cfish fcfish pfish fpfish)],
112             edges => $enum_yes_no,
113             nodes => $enum_yes_no,
114             splines => $enum_yes_no,
115             bmax => VCG_ATTR_TYPE_INTEGER,
116             cmax => VCG_ATTR_TYPE_INTEGER,
117             cmin => VCG_ATTR_TYPE_INTEGER,
118             pmax => VCG_ATTR_TYPE_INTEGER,
119             pmin => VCG_ATTR_TYPE_INTEGER,
120             rmax => VCG_ATTR_TYPE_INTEGER,
121             rmin => VCG_ATTR_TYPE_INTEGER,
122             smax => VCG_ATTR_TYPE_INTEGER,
123              
124             },
125             node => {
126              
127             %common_attrs,
128              
129             info1 => VCG_ATTR_TYPE_STRING,
130             info2 => VCG_ATTR_TYPE_STRING,
131             info3 => VCG_ATTR_TYPE_STRING,
132             bordercolor => $enum_color,
133             width => VCG_ATTR_TYPE_INTEGER,
134             height => VCG_ATTR_TYPE_INTEGER,
135             borderwidth => VCG_ATTR_TYPE_INTEGER,
136             # loc
137             folding => VCG_ATTR_TYPE_INTEGER,
138             scaling => VCG_ATTR_TYPE_FLOAT,
139             shrink => VCG_ATTR_TYPE_INTEGER,
140             stretch => VCG_ATTR_TYPE_INTEGER,
141             textmode => $enum_textmode,
142             shape => $enum_shape,
143             level => VCG_ATTR_TYPE_INTEGER,
144             vertical_order => VCG_ATTR_TYPE_INTEGER,
145             horizontal_order => VCG_ATTR_TYPE_INTEGER,
146              
147             },
148             edge => {
149              
150             %common_attrs,
151              
152             thickness => VCG_ATTR_TYPE_INTEGER,
153             class => VCG_ATTR_TYPE_INTEGER,
154             priority => VCG_ATTR_TYPE_INTEGER,
155             arrowcolor => $enum_color,
156             backarrowcolor => $enum_color,
157             arrowsize => VCG_ATTR_TYPE_INTEGER,
158             backarrowsize => VCG_ATTR_TYPE_INTEGER,
159             arrowstyle => $enum_arrowstyle,
160             backarrowstyle => $enum_arrowstyle,
161             linestyle => [qw(continuous solid dotted
162             dashed invisible)],
163             anchor => VCG_ATTR_TYPE_INTEGER,
164             horizontal_order => VCG_ATTR_TYPE_INTEGER,
165              
166             },
167             );
168              
169             #=======================================================================
170             #
171             # _write_graph()
172             #
173             # The private method which actually does the writing out in
174             # VCG format.
175             #
176             # This is called from the public method, write_graph(), which is
177             # found in Graph::Writer.
178             #
179             #=======================================================================
180             sub _write_graph
181             {
182 1     1   2 my $self = shift;
183 1         2 my $graph = shift;
184 1         2 my $FILE = shift;
185              
186 1         2 my $v;
187             my $from;
188 0         0 my $to;
189 0         0 my $aref;
190 0         0 my @keys;
191              
192              
193             #-------------------------------------------------------------------
194             #-------------------------------------------------------------------
195 1         5 print $FILE "graph: {\n";
196              
197             #-------------------------------------------------------------------
198             # Dump out any overall attributes of the graph
199             #-------------------------------------------------------------------
200 1         12 $aref = $graph->get_graph_attributes();
201 1         18 _render_attributes('graph', $aref, $FILE);
202              
203             #-------------------------------------------------------------------
204             # Dump out a list of the nodes, along with any defined attributes
205             #-------------------------------------------------------------------
206 1         5 foreach $v (sort $graph->vertices)
207             {
208 5         72 print $FILE " node: { title: \"$v\"";
209 5         16 $aref = $graph->get_vertex_attributes($v);
210 5         398 _render_attributes('node', $aref, $FILE, 1);
211 5         10 print $FILE " }\n";
212             }
213 1         4 print $FILE "\n";
214              
215             #-------------------------------------------------------------------
216             # Dump out a list of the edges, along with any defined attributes
217             #-------------------------------------------------------------------
218 1         4 foreach my $edge (sort _by_vertex $graph->edges)
219             {
220 7         18 ($from, $to) = @$edge;
221 7         15 print $FILE " edge: { sourcename: \"$from\" targetname: \"$to\"";
222 7         18 $aref = $graph->get_edge_attributes($from, $to);
223 7         1955 _render_attributes('edge', $aref, $FILE, 1);
224 7         12 print $FILE " }\n";
225             }
226              
227 1         5 print $FILE "}\n";
228              
229 1         3 return 1;
230             }
231              
232              
233             sub _by_vertex
234             {
235 13     13   159 return $a->[0].$a->[1] cmp $b->[0].$b->[1];
236             }
237              
238              
239             #=======================================================================
240             #
241             # _render_attributes
242             #
243             # Take a hash of attribute names and values and format
244             # as VCG attribute specs, quoting the value if needed.
245             # We filter the hash against legal attributes, since VCG will
246             # barf on unknown attribute names.
247             #
248             # Returns the number of attributes written out.
249             #
250             #=======================================================================
251             sub _render_attributes
252             {
253 13     13   21 my $entity = shift; # 'graph' or 'node' or 'edge'
254 13         17 my $attref = shift;
255 13         16 my $FILE = shift;
256 13 100       27 my $depth = @_ > 0 ? shift : 0;
257              
258 13         18 my @keys;
259             my $type;
260              
261              
262 13         15 @keys = grep(exists $attref->{$_}, keys %{$valid_attributes{$entity}});
  13         100  
263 13 50       43 if (@keys > 0)
264             {
265 0         0 print $FILE "\n";
266 0         0 foreach my $a (@keys)
267             {
268 0         0 $type = $valid_attributes{$entity}->{$a};
269 0 0 0     0 if (ref $type || $type == VCG_ATTR_TYPE_INTEGER
      0        
270             || $type == VCG_ATTR_TYPE_FLOAT)
271             {
272 0         0 print $FILE " ", ' ' x $depth, "$a: ", $attref->{$a}, "\n";
273             }
274             else
275             {
276             print $FILE " ", ' ' x $depth,
277 0         0 "$a: \"", $attref->{$a}, "\"\n";
278             }
279             }
280             }
281 13         27 return int @keys;
282             }
283              
284             1;
285              
286             __END__