File Coverage

lib/Graph/Easy/As_graphviz.pm
Criterion Covered Total %
statement 364 501 72.6
branch 214 324 66.0
condition 82 113 72.5
subroutine 28 33 84.8
pod 1 2 50.0
total 689 973 70.8


line stmt bran cond sub pod time code
1             #############################################################################
2             # output the graph in dot-format text
3             #
4             #############################################################################
5              
6             package Graph::Easy::As_graphviz;
7              
8             $VERSION = '0.76';
9              
10             #############################################################################
11             #############################################################################
12              
13             package Graph::Easy;
14              
15 2     2   8 use strict;
  2         2  
  2         66  
16 2     2   8 use warnings;
  2         2  
  2         69  
17              
18 2     2   6 use Graph::Easy::Util qw(ord_values);
  2         2  
  2         4011  
19              
20             my $remap = {
21             node => {
22             'align' => undef,
23             'background' => undef, # need a way to simulate that on non-rect nodes
24             'basename' => undef,
25             'bordercolor' => \&_remap_color,
26             'borderstyle' => \&_graphviz_remap_border_style,
27             'borderwidth' => undef,
28             'border' => undef,
29             'color' => \&_remap_color,
30             'fill' => \&_remap_color,
31             'label' => \&_graphviz_remap_label,
32             'pointstyle' => undef,
33             'pointshape' => undef,
34             'rotate' => \&_graphviz_remap_node_rotate,
35             'shape' => \&_graphviz_remap_node_shape,
36             'title' => 'tooltip',
37             'rows' => undef,
38             'columns' => undef,
39             },
40             edge => {
41             'align' => undef,
42             'arrowstyle' => \&_graphviz_remap_arrow_style,
43             'background' => undef,
44             'color' => \&_graphviz_remap_edge_color,
45             'end' => \&_graphviz_remap_port,
46             'headtitle' => 'headtooltip',
47             'headlink' => 'headURL',
48             'labelcolor' => \&_graphviz_remap_label_color,
49             'start' => \&_graphviz_remap_port,
50             'style' => \&_graphviz_remap_edge_style,
51             'tailtitle' => 'tailtooltip',
52             'taillink' => 'tailURL',
53             'title' => 'tooltip',
54             'minlen' => \&_graphviz_remap_edge_minlen,
55             },
56             graph => {
57             align => \&_graphviz_remap_align,
58             background => undef,
59             bordercolor => \&_remap_color,
60             borderstyle => \&_graphviz_remap_border_style,
61             borderwidth => undef,
62             color => \&_remap_color,
63             fill => \&_remap_color,
64             gid => undef,
65             label => \&_graphviz_remap_label,
66             labelpos => 'labelloc',
67             output => undef,
68             type => undef,
69             },
70             group => {
71             align => \&_graphviz_remap_align,
72             background => undef,
73             bordercolor => \&_remap_color,
74             borderstyle => \&_graphviz_remap_border_style,
75             borderwidth => undef,
76             color => \&_remap_color,
77             fill => \&_remap_color,
78             labelpos => 'labelloc',
79             rank => undef,
80             title => 'tooltip',
81             },
82             all => {
83             arrowshape => undef,
84             autolink => undef,
85             autotitle => undef,
86             autolabel => undef,
87             class => undef,
88             colorscheme => undef,
89             flow => undef,
90             fontsize => \&_graphviz_remap_fontsize,
91             font => \&_graphviz_remap_font,
92             format => undef,
93             group => undef,
94             link => \&_graphviz_remap_link,
95             linkbase => undef,
96             textstyle => undef,
97             textwrap => undef,
98             },
99             always => {
100             node => [ qw/borderstyle label link rotate color fill/ ],
101             'node.anon' => [ qw/bordercolor borderstyle label link rotate color/ ],
102             edge => [ qw/labelcolor label link color/ ],
103             graph => [ qw/labelpos borderstyle label link color/ ],
104             },
105             # this routine will handle all custom "x-dot-..." attributes
106             x => \&_remap_custom_dot_attributes,
107             };
108              
109             sub _remap_custom_dot_attributes
110             {
111 42     42   44 my ($self, $name, $value) = @_;
112              
113             # drop anything that is not starting with "x-dot-..."
114 42 50       112 return (undef,undef) unless $name =~ /^x-dot-/;
115              
116 0         0 $name =~ s/^x-dot-//; # "x-dot-foo" => "foo"
117 0         0 ($name,$value);
118             }
119              
120             my $color_remap = {
121             bordercolor => 'color',
122             color => 'fontcolor',
123             fill => 'fillcolor',
124             };
125              
126             sub _remap_color
127             {
128             # remap one color value
129 563     563   558 my ($self, $name, $color, $object) = @_;
130              
131             # guard against always doing the remap even when the attribute is not set
132 563 100       995 return (undef,undef) unless defined $color;
133              
134 252 100 100     553 if (!ref($object) && $object eq 'graph')
135             {
136             # 'fill' => 'bgcolor';
137 57 100       89 $name = 'bgcolor' if $name eq 'fill';
138             }
139              
140 252   66     485 $name = $color_remap->{$name} || $name;
141              
142 252         381 $color = $self->_color_as_hex_or_hsv($object,$color);
143              
144 252         480 ($name, $color);
145             }
146              
147             sub _color_as_hex_or_hsv
148             {
149             # Given a color in hex, hsv, hsl or rgb, will return either a hex or hsv
150             # color to preserve as much precision as possible:
151 353     353   343 my ($graph, $self, $color) = @_;
152              
153 353 100       612 if ($color !~ /^#/)
154             {
155             # HSV colors with an alpha channel are not supported by graphviz, and
156             # hence converted to RGB here:
157 278 100       327 if ($color =~ /^hsv\(([0-9\.]+),([0-9\.]+),([0-9\.]+)\)/)
158             {
159             # hsv(1.0,1.0,1.0) => 1.0 1.0 1.0
160 1         4 $color = "$1 $2 $3";
161             }
162             else
163             {
164 277 100       526 my $cs = ref($self) ? $self->attribute('colorscheme') :
165             $graph->attribute($self,'colorscheme');
166             # red => hex
167 277         538 $color = $graph->color_as_hex($color, $cs);
168             }
169             }
170              
171 353         379 $color;
172             }
173              
174             sub _graphviz_remap_align
175             {
176 14     14   18 my ($self, $name, $style) = @_;
177              
178 14         26 my $s = lc(substr($style,0,1)); # 'l', 'r', or 'c'
179              
180 14         31 ('labeljust', $s);
181             }
182              
183             sub _graphviz_remap_edge_minlen
184             {
185 0     0   0 my ($self, $name, $len) = @_;
186              
187 0         0 $len = int(($len + 1) / 2);
188 0         0 ($name, $len);
189             }
190              
191             sub _graphviz_remap_edge_color
192             {
193 98     98   104 my ($self, $name, $color, $object) = @_;
194              
195 98 50       204 my $style = ref($object) ?
196             $object->attribute('style') :
197             $self->attribute('edge','style');
198              
199 98 100       136 if (!defined $color)
200             {
201 72 50       156 $color = ref($object) ?
202             $object->attribute('color') :
203             $self->attribute('edge','color');
204             }
205              
206 98 50       128 $color = '#000000' unless defined $color;
207 98         135 $color = $self->_color_as_hex_or_hsv($object, $color);
208              
209 98 100       130 $color = $color . ':' . $color # 'red:red'
210             if $style =~ /^double/;
211              
212 98         202 ($name, $color);
213             }
214              
215             sub _graphviz_remap_edge_style
216             {
217 5     5   718 my ($self, $name, $style) = @_;
218              
219             # valid output styles are: solid dashed dotted bold invis
220              
221 5 50       10 $style = 'solid' unless defined $style;
222              
223 5 50       11 $style = 'dotted' if $style =~ /^dot-/; # dot-dash, dot-dot-dash
224 5 50       8 $style = 'dotted' if $style =~ /^wave/; # wave
225              
226             # double lines will be handled in the color attribute as "color:color"
227 5 100       11 $style = 'solid' if $style eq 'double'; # double
228 5 100       9 $style = 'dashed' if $style =~ /^double-dash/;
229              
230 5 50       8 $style = 'invis' if $style eq 'invisible'; # invisible
231              
232             # XXX TODO: These should be (2, 0.5em, 1em) instead of 2,5,11
233 5 50       7 $style = 'setlinewidth(2), dashed' if $style =~ /^bold-dash/;
234 5 50       9 $style = 'setlinewidth(5)' if $style =~ /^broad/;
235 5 50       8 $style = 'setlinewidth(11)' if $style =~ /^wide/;
236              
237 5 100       10 return (undef, undef) if $style eq 'solid'; # default style can be suppressed
238              
239 2         7 ($name, $style);
240             }
241              
242             sub _graphviz_remap_node_rotate
243             {
244 208     208   211 my ($graph, $name, $angle, $self) = @_;
245              
246             # do this only for objects, not classes
247 208 50 33     871 return (undef,undef) unless ref($self) && defined $angle;
248              
249 0 0       0 return (undef,undef) if $angle == 0;
250              
251             # despite what the manual says, dot rotates counter-clockwise, so fix that
252 0         0 $angle = 360 - $angle;
253              
254 0         0 ('orientation', $angle);
255             }
256              
257             sub _graphviz_remap_port
258             {
259 4     4   5 my ($graph, $name, $side, $self) = @_;
260              
261             # do this only for objects, not classes
262 4 50 33     15 return (undef,undef) unless ref($self) && defined $side;
263              
264             # XXX TODO
265             # remap relative ports (front etc) to "south" etc
266              
267             # has a specific port, aka shared a port with another edge
268 4 50       8 return (undef, undef) if $side =~ /,/;
269              
270 4         9 $side = $graph->_flow_as_side($self->flow(),$side);
271              
272 4         6 $side = substr($side,0,1); # "south" => "s"
273              
274 4 100       3 my $n = 'tailport'; $n = 'headport' if $name eq 'end';
  4         7  
275              
276 4         10 ($n, $side);
277             }
278              
279             sub _graphviz_remap_font
280             {
281             # Remap the font names
282 14     14   19 my ($self, $name, $style) = @_;
283              
284             # XXX TODO: "times" => "Times.ttf" ?
285 14         30 ('fontname', $style);
286             }
287              
288             sub _graphviz_remap_fontsize
289             {
290             # make sure the fontsize is in pixel or percent
291 19     19   21 my ($self, $name, $style) = @_;
292              
293             # XXX TODO: This should be actually 1 em
294 19         17 my $fs = '11';
295              
296 19 50       68 if ($style =~ /^([\d\.]+)em\z/)
    0          
    0          
297             {
298 19         56 $fs = $1 * 11;
299             }
300             elsif ($style =~ /^([\d\.]+)%\z/)
301             {
302 0         0 $fs = ($1 / 100) * 11;
303             }
304             # this is discouraged:
305             elsif ($style =~ /^([\d\.]+)px\z/)
306             {
307 0         0 $fs = $1;
308             }
309             else
310             {
311 0         0 $self->_croak("Illegal font-size '$style'");
312             }
313              
314             # font-size => fontsize
315 19         44 ('fontsize', $fs);
316             }
317              
318             sub _graphviz_remap_border_style
319             {
320 222     222   227 my ($self, $name, $style, $node) = @_;
321              
322 222         168 my $shape = '';
323 222 100 50     472 $shape = ($node->attribute('shape') || '') if ref($node);
324              
325             # some shapes don't need a border:
326 222 100       512 return (undef,undef) if $shape =~ /^(none|invisible|img|point)\z/;
327              
328 219 100       475 $style = $node->attribute('borderstyle') unless defined $style;
329              
330             # valid styles are: solid dashed dotted bold invis
331              
332 219 50       318 $style = '' unless defined $style;
333              
334 219 50       329 $style = 'dotted' if $style =~ /^dot-/; # dot-dash, dot-dot-dash
335 219 50       264 $style = 'dashed' if $style =~ /^double-/; # double-dash
336 219 50       265 $style = 'dotted' if $style =~ /^wave/; # wave
337              
338             # borderstyle double will be handled extra with peripheries=2 later
339 219 100       246 $style = 'solid' if $style eq 'double';
340              
341             # XXX TODO: These should be (2, 0.5em, 1em) instead of 2,5,11
342 219 50       257 $style = 'setlinewidth(2)' if $style =~ /^bold/;
343 219 100       249 $style = 'setlinewidth(5)' if $style =~ /^broad/;
344 219 50       260 $style = 'setlinewidth(11)' if $style =~ /^wide/;
345              
346             # "solid 0px" => "none"
347 219 100 100     177 my $w = 0; $w = $node->attribute('borderwidth') if (ref($node) && $style ne 'none');
  219         827  
348 219 100       409 $style = 'none' if $w == 0;
349              
350 219         142 my @rc;
351 219 100       279 if ($style eq 'none')
352             {
353 18 100       11 my $fill = 'white'; $fill = $node->color_attribute('fill') if ref($node);
  18         36  
354 18         12 $style = 'filled'; @rc = ('color', $fill);
  18         26  
355             }
356              
357             # default style can be suppressed
358 219 100 100     1160 return (undef, undef) if $style =~ /^(|solid)\z/ && $shape ne 'rounded';
359              
360             # for graphviz v2.4 and up
361 24 100       29 $style = 'filled' if $style eq 'solid';
362 24 100       48 $style = 'filled,'.$style unless $style eq 'filled';
363 24 100 66     50 $style = 'rounded,'.$style if $shape eq 'rounded' && $style ne 'none';
364              
365 24         26 $style =~ s/,\z//; # "rounded," => "rounded"
366              
367 24         27 push @rc, 'style', $style;
368 24         54 @rc;
369             }
370              
371             sub _graphviz_remap_link
372             {
373 306     306   289 my ($self, $name, $l, $object) = @_;
374              
375             # do this only for objects, not classes
376 306 50       418 return (undef,undef) unless ref($object);
377              
378 306 50       782 $l = $object->link() unless defined $l;
379              
380 306         650 ('URL', $l);
381             }
382              
383             sub _graphviz_remap_label_color
384             {
385 98     98   101 my ($graph, $name, $color, $self) = @_;
386              
387             # do this only for objects, not classes
388 98 50       140 return (undef,undef) unless ref($self);
389              
390             # no label => no color nec.
391 98 100 100     192 return (undef, $color) if ($self->label()||'') eq '';
392              
393 3 100       10 $color = $self->raw_attribute('labelcolor') unless defined $color;
394              
395             # the label color falls back to the edge color
396 3 100       10 $color = $self->attribute('color') unless defined $color;
397              
398 3         8 $color = $graph->_color_as_hex_or_hsv($self,$color);
399              
400 3         7 ('fontcolor', $color);
401             }
402              
403             sub _graphviz_remap_node_shape
404             {
405 52     52   52 my ($self, $name, $style, $object) = @_;
406              
407             # img needs no shape, and rounded is handled as style
408 52 100       137 return (undef,undef) if $style =~ /^(img|rounded)\z/;
409              
410             # valid styles are: solid dashed dotted bold invis
411              
412 51         47 my $s = $style;
413 51 100       85 $s = 'plaintext' if $style =~ /^(invisible|none|point)\z/;
414              
415 51 50       84 if (ref($object))
416             {
417 51         80 my $border = $object->attribute('borderstyle');
418 51 50       76 $s = 'plaintext' if $border eq 'none';
419             }
420              
421 51         94 ($name, $s);
422             }
423              
424             sub _graphviz_remap_arrow_style
425             {
426 113     113   117 my ($self, $name, $style) = @_;
427              
428 113         97 my $s = 'normal';
429              
430 113 100       284 $s = $style if $style =~ /^(none|open)\z/;
431 113 100       154 $s = 'empty' if $style eq 'closed';
432              
433 113         78 my $n = 'arrowhead';
434 113 100       167 $n = 'arrowtail' if $self->{_flip_edges};
435              
436 113         188 ($n, $s);
437             }
438              
439             sub _graphviz_remap_label
440             {
441 261     261   256 my ($self, $name, $label, $node) = @_;
442              
443 261         183 my $s = $label;
444              
445             # call label() to handle thinks like "autolabel: 15" properly
446 261 100       586 $s = $node->label() if ref($node);
447              
448 261 100       372 if (ref($node))
449             {
450             # remap all "\n" and "\c" to either "\l" or "\r", depending on align
451 208         324 my $align = $node->attribute('align');
452 208         167 my $next_line = '\n';
453             # the align of the line-ends counts for the line _before_ them, so
454             # add one more to fix the last line
455 208 50       287 $next_line = '\l', $s .= '\l' if $align eq 'left';
456 208 50       253 $next_line = '\r', $s .= '\r' if $align eq 'right';
457              
458 208         232 $s =~ s/(^|[^\\])\\n/$1$next_line/g; # \n => align
459             }
460              
461 261         193 $s =~ s/(^|[^\\])\\c/$1\\n/g; # \c => \n (for center)
462              
463 261         165 my $shape = 'rect';
464 261 100 50     541 $shape = ($node->attribute('shape') || '') if ref($node);
465              
466             # only for nodes and when they have a "shape: img"
467 261 50       344 if ($shape eq 'img')
468             {
469 0         0 my $s = '<
>';
470              
471 0         0 my $url = $node->label();
472 0         0 $url =~ s/\s/\+/g; # space
473 0         0 $url =~ s/'/%27/g; # replace quotation marks
474 0         0 $s =~ s/##url##/$url/g;
475             }
476              
477 261         539 ($name, $s);
478             }
479              
480             #############################################################################
481              
482             sub _att_as_graphviz
483             {
484             # convert a hash with attribute => value mappings to a string
485 246     246   225 my ($self, $out) = @_;
486              
487 246         209 my $att = '';
488 246         664 for my $atr (sort keys %$out)
489             {
490 640         504 my $v = $out->{$atr};
491 640         514 $v =~ s/\n/\\n/g;
492              
493 640 100       1290 $v = '"' . $v . '"' if $v !~ /^[a-z0-9A-Z]+\z/; # quote if nec.
494              
495             # convert "x-dot-foo" to "foo". Special case "K":
496 640 50       426 my $name = $atr; $name =~ s/^x-dot-//; $name = 'K' if $name eq 'k';
  640         398  
  640         713  
497              
498 640         1024 $att .= " $name=$v,\n";
499             }
500              
501 246         603 $att =~ s/,\n\z/ /; # remove last ","
502 246 50       397 if ($att ne '')
503             {
504             # the following makes short, single definitions to fit on one line
505 246 100 66     803 if ($att !~ /\n.*\n/ && length($att) < 40)
506             {
507 107         118 $att =~ s/\n/ /; $att =~ s/( )+/ /g;
  107         301  
508             }
509             else
510             {
511 139         350 $att =~ s/\n/\n /g;
512 139         185 $att = "\n $att";
513             }
514             }
515 246         324 $att;
516             }
517              
518 2     2   13 use Graph::Easy::Util qw(first_kv);
  2         2  
  2         6048  
519              
520             sub _generate_group_edge
521             {
522             # Given an edge (from/to at least one group), generate the graphviz code
523 0     0   0 my ($self, $e, $indent) = @_;
524              
525 0         0 my $edge_att = $e->attributes_as_graphviz();
526              
527 0         0 my $a = ''; my $b = '';
  0         0  
528 0         0 my $from = $e->{from};
529 0         0 my $to = $e->{to};
530              
531 0 0       0 ($from,$to) = ($to,$from) if $self->{_flip_edges};
532 0 0       0 if ($from->isa('Graph::Easy::Group'))
533             {
534             # find an arbitray node inside the group
535 0         0 my ($n, $v) = first_kv($from->{nodes});
536              
537 0         0 $a = 'ltail="cluster' . $from->{id}.'"'; # ltail=cluster0
538 0         0 $from = $v;
539             }
540              
541             # XXX TODO:
542             # this fails for empty groups
543 0 0       0 if ($to->isa('Graph::Easy::Group'))
544             {
545             # find an arbitray node inside the group
546 0         0 my ($n, $v) = first_kv($to->{nodes});
547              
548 0         0 $b = 'lhead="cluster' . $to->{id}.'"'; # lhead=cluster0
549 0         0 $to = $v;
550             }
551              
552 0         0 my $other = $to->_graphviz_point();
553 0         0 my $first = $from->_graphviz_point();
554              
555 0         0 $e->{_p} = undef; # mark as processed
556              
557 0         0 my $att = $a;
558 0 0       0 $att .= ', ' . $b if $b ne ''; $att =~ s/^,//;
  0         0  
559 0 0       0 if ($att ne '')
560             {
561 0 0       0 if ($edge_att eq '')
562             {
563 0         0 $edge_att = " [ $att ]";
564             }
565             else
566             {
567 0         0 $edge_att =~ s/ \]/, $att \]/;
568             }
569             }
570              
571 0         0 "$indent$first $self->{edge_type} $other$edge_att\n"; # return edge text
572             }
573              
574             sub _insert_edge_attribute
575             {
576             # insert an additional attribute into an edge attribute string
577 0     0   0 my ($self, $att, $new_att) = @_;
578              
579 0 0       0 return '[ $new_att ]' if $att eq ''; # '' => '[ ]'
580              
581             # remove any potential old attribute with the same name
582 0         0 my $att_name = $new_att; $att_name =~ s/=.*//;
  0         0  
583 0         0 $att =~ s/$att_name=("[^"]+"|[^\s]+)//;
584              
585             # insert the new attribute at the end
586 0         0 $att =~ s/\s?\]/,$new_att ]/;
587              
588 0         0 $att;
589             }
590              
591             sub _suppress_edge_attribute
592             {
593             # remove the named attribute from the edge attribute string
594 0     0   0 my ($self, $att, $sup_att) = @_;
595              
596 0         0 $att =~ s/$sup_att=("(\\"|[^"])*"|[^\s\n,;]+)[,;]?//;
597 0         0 $att;
598             }
599              
600             sub _generate_edge
601             {
602             # Given an edge, generate the graphviz code for it
603 98     98   95 my ($self, $e, $indent) = @_;
604              
605             # skip links from/to groups, these will be done later
606             return '' if
607             $e->{from}->isa('Graph::Easy::Group') ||
608 98 50 33     566 $e->{to}->isa('Graph::Easy::Group');
609              
610 98         89 my $invis = $self->{_graphviz_invis};
611              
612             # attributes for invisible helper nodes (the color will be filled in from the edge color)
613 98         78 my $inv = ' [ label="",shape=none,style=filled,height=0,width=0,fillcolor="';
614              
615 98         132 my $other = $e->{to}->_graphviz_point();
616 98         133 my $first = $e->{from}->_graphviz_point();
617              
618 98         153 my $edge_att = $e->attributes_as_graphviz();
619 98         84 my $txt = '';
620              
621 98         74 my $modify_edge = 0;
622 98 100       152 my $suppress_start = (!$self->{_flip_edges} ? 'arrowtail=none' : 'arrowhead=none');
623 98 100       118 my $suppress_end = ( $self->{_flip_edges} ? 'arrowtail=none' : 'arrowhead=none');
624 98         64 my $suppress;
625              
626             # if the edge has a shared start/end port
627 98 100       196 if ($e->has_ports())
628             {
629 2         3 my @edges = ();
630              
631 2         6 my ($side,@port) = $e->port('start');
632 2 50 33     8 @edges = $e->{from}->edges_at_port('start',$side,@port) if defined $side && @port > 0;
633              
634 2 50       8 if (@edges > 1) # has strict port
635             {
636             # access the invisible node
637 0         0 my $sp = $e->port('start');
638 0         0 my $key = "$e->{from}->{name},start,$sp";
639 0         0 my $invis_id = $invis->{$key};
640 0         0 $suppress = $suppress_start;
641 0 0       0 if (!defined $invis_id)
642             {
643             # create the invisible helper node
644             # find a name for it, carefully avoiding names of other nodes:
645 0         0 $self->{_graphviz_invis_id}++ while (defined $self->node($self->{_graphviz_invis_id}));
646 0         0 $invis_id = $self->{_graphviz_invis_id}++;
647              
648             # output the helper node
649 0         0 my $e_color = $e->color_attribute('color');
650 0         0 $txt .= $indent . "$invis_id$inv$e_color\" ]\n";
651 0         0 my $e_att = $self->_insert_edge_attribute($edge_att,$suppress_end);
652 0         0 $e_att = $self->_suppress_edge_attribute($e_att,'label');
653 0         0 my $before = ''; my $after = ''; my $i = $indent;
  0         0  
  0         0  
654 0 0       0 if ($e->{group})
655             {
656 0         0 $before = $indent . 'subgraph "cluster' . $e->{group}->{id} . "\" {\n";
657 0         0 $after = $indent . "}\n";
658 0         0 $i = $indent . $indent;
659             }
660 0 0       0 if ($self->{_flip_edges})
661             {
662 0         0 $txt .= $before . $i . "$invis_id $self->{_edge_type} $first$e_att\n" . $after;
663             }
664             else
665             {
666 0         0 $txt .= $before . $i . "$first $self->{_edge_type} $invis_id$e_att\n" . $after;
667             }
668 0         0 $invis->{$key} = $invis_id; # mark as created
669             }
670             # "joint0" etc
671 0         0 $first = $invis_id;
672 0         0 $modify_edge++;
673             }
674              
675 2         4 ($side,@port) = $e->port('end');
676 2         3 @edges = ();
677 2 50 33     7 @edges = $e->{to}->edges_at_port('end',$side,@port) if defined $side && @port > 0;
678 2 50       5 if (@edges > 1)
679             {
680 0         0 my $ep = $e->port('end');
681 0         0 my $key = "$e->{to}->{name},end,$ep";
682 0         0 my $invis_id = $invis->{$key};
683 0         0 $suppress = $suppress_end;
684              
685 0 0       0 if (!defined $invis_id)
686             {
687             # create the invisible helper node
688             # find a name for it, carefully avoiding names of other nodes:
689 0         0 $self->{_graphviz_invis_id}++ while (defined $self->node($self->{_graphviz_invis_id}));
690 0         0 $invis_id = $self->{_graphviz_invis_id}++;
691              
692 0         0 my $e_att = $self->_insert_edge_attribute($edge_att,$suppress_start);
693             # output the helper node
694 0         0 my $e_color = $e->color_attribute('color');
695 0         0 $txt .= $indent . "$invis_id$inv$e_color\" ]\n";
696 0         0 my $before = ''; my $after = ''; my $i = $indent;
  0         0  
  0         0  
697 0 0       0 if ($e->{group})
698             {
699 0         0 $before = $indent . 'subgraph "cluster' . $e->{group}->{id} . "\" {\n";
700 0         0 $after = $indent . "}\n";
701 0         0 $i = $indent . $indent;
702             }
703 0 0       0 if ($self->{_flip_edges})
704             {
705 0         0 $txt .= $before . $i . "$other $self->{_edge_type} $invis_id$e_att\n" . $after;
706             }
707             else
708             {
709 0         0 $txt .= $before . $i . "$invis_id $self->{_edge_type} $other$e_att\n" . $after;
710             }
711 0         0 $invis->{$key} = $invis_id; # mark as output
712             }
713             # "joint1" etc
714 0         0 $other = $invis_id;
715 0         0 $modify_edge++;
716             }
717             }
718              
719 98 100       178 ($other,$first) = ($first,$other) if $self->{_flip_edges};
720              
721 98         118 $e->{_p} = undef; # mark as processed
722              
723 98 50       121 $edge_att = $self->_insert_edge_attribute($edge_att,$suppress)
724             if $modify_edge;
725              
726 98         426 $txt . "$indent$first $self->{_edge_type} $other$edge_att\n"; # return edge text
727             }
728              
729             sub _order_group
730             {
731 17     17   17 my ($self,$group) = @_;
732 17         19 $group->{_order}++;
733 17         26 for my $sg (ord_values( $group->{groups}))
734             {
735 3         6 $self->_order_group($sg);
736             }
737             }
738              
739              
740             sub _as_graphviz_group
741             {
742 16     16   18 my ($self,$group) = @_;
743              
744 16         14 my $txt = '';
745             # quote special chars in group name
746 16         17 my $name = $group->{name}; $name =~ s/([\[\]\(\)\{\}\#"])/\\$1/g;
  16         31  
747              
748 16 100       30 return if $group->{_p};
749             # output group attributes first
750 14         21 my $indent = ' ' x ($group->{_order});
751 14         35 $txt .= $indent."subgraph \"cluster$group->{id}\" {\n${indent}label=\"$name\";\n";
752              
753 14         17 for my $sg (ord_values ( $group->{groups} ))
754             {
755             #print '--'.$sg->{name}."\n";
756 2         8 $txt .= $self->_as_graphviz_group($sg,$indent);
757 2         4 $sg->{_p} = 1;
758             }
759             # Make a copy of the attributes, including our class attributes:
760 14         18 my $copy = {};
761 14         32 my $attribs = $group->get_attributes();
762              
763 14         133 for my $key (sort keys %$attribs)
764             {
765 420         381 $copy->{$key} = $attribs->{$key};
766             }
767             # set some defaults
768 14 50       57 $copy->{'borderstyle'} = 'solid' unless defined $copy->{'borderstyle'};
769              
770 14         30 my $out = $self->_remap_attributes( $group->class(), $copy, $remap, 'noquote');
771              
772             # Set some defaults:
773 14 50       27 $out->{fillcolor} = '#a0d0ff' unless defined $out->{fillcolor};
774 14 50       21 $out->{labeljust} = 'l' unless defined $out->{labeljust};
775              
776 14         12 my $att = '';
777             # we need to output style first ("filled" and "color" need come later)
778 14         55 for my $atr (reverse sort keys %$out)
779             {
780 112         99 my $v = $out->{$atr};
781 112 100       281 $v = '"' . $v . '"' if $v !~ /^[a-z0-9A-Z]+\z/; # quote if nec.
782              
783             # convert "x-dot-foo" to "foo". Special case "K":
784 112 50       70 my $name = $atr; $name =~ s/^x-dot-//; $name = 'K' if $name eq 'k';
  112         76  
  112         125  
785              
786 112         153 $att .= $indent."$name=$v;\n";
787             }
788 14 50       69 $txt .= $att . "\n" if $att ne '';
789              
790             # output nodes (w/ or w/o attributes) in that group
791 14         44 for my $n ($group->sorted_nodes())
792             {
793             # skip nodes that are relativ to others (these are done as part
794             # of the HTML-like label of their parent)
795 18 50       31 next if $n->{origin};
796              
797 18         27 my $att = $n->attributes_as_graphviz();
798 18         26 $n->{_p} = undef; # mark as processed
799 18         31 $txt .= $indent . $n->as_graphviz_txt() . $att . "\n";
800             }
801              
802             # output node connections in this group
803 14         44 for my $e (ord_values $group->{edges})
804             {
805 0 0       0 next if exists $e->{_p};
806 0         0 $txt .= $self->_generate_edge($e, $indent);
807             }
808              
809 14         23 $txt .= $indent."}\n";
810              
811 14         114 return $txt;
812             }
813              
814             sub _as_graphviz
815             {
816 82     82   86 my ($self) = @_;
817              
818             # convert the graph to a textual representation
819             # does not need a layout() beforehand!
820              
821 82   50     302 my $name = "GRAPH_" . ($self->{gid} || '0');
822              
823 82         166 my $type = $self->attribute('type');
824 82 50       123 $type = $type eq 'directed' ? 'digraph' : 'graph'; # directed or undirected?
825              
826 82 50       148 $self->{_edge_type} = $type eq 'digraph' ? '->' : '--'; # "a -- b" vs "a -> b"
827              
828 82         1921 my $txt = "$type $name {\n\n" .
829             " // Generated by Graph::Easy $Graph::Easy::VERSION" .
830             " at " . scalar localtime() . "\n\n";
831              
832              
833 82         183 my $flow = $self->attribute('graph','flow');
834 82 50       119 $flow = 'east' unless defined $flow;
835              
836 82         192 $flow = Graph::Easy->_direction_as_number($flow);
837              
838             # for LR, BT layouts
839 82         94 $self->{_flip_edges} = 0;
840 82 100 100     248 $self->{_flip_edges} = 1 if $flow == 270 || $flow == 0;
841              
842 82         175 my $groups = $self->groups();
843              
844             # to keep track of invisible helper nodes
845 82         100 $self->{_graphviz_invis} = {};
846             # name for invisible helper nodes
847 82         84 $self->{_graphviz_invis_id} = 'joint0';
848              
849             # generate the class attributes first
850 82         68 my $atts = $self->{att};
851             # It is not possible to set attributes for groups in the DOT language that way
852 82         95 for my $class (qw/edge graph node/)
853             {
854 246 50       371 next if $class =~ /\./; # skip subclasses
855              
856 246         564 my $out = $self->_remap_attributes( $class, $atts->{$class}, $remap, 'noquote');
857              
858             # per default, our nodes are rectangular, white, filled boxes
859 246 100       522 if ($class eq 'node')
    100          
    50          
860             {
861 82 50       170 $out->{shape} = 'box' unless $out->{shape};
862 82 50       135 $out->{style} = 'filled' unless $out->{style};
863 82 50       142 $out->{fontsize} = '11' unless $out->{fontsize};
864 82 50       125 $out->{fillcolor} = 'white' unless $out->{fillcolor};
865             }
866             elsif ($class eq 'graph')
867             {
868 82 100 100     227 $out->{rankdir} = 'LR' if $flow == 90 || $flow == 270;
869 82 100 100     207 $out->{labelloc} = 'top' if defined $out->{label} && !defined $out->{labelloc};
870 82 100       116 $out->{style} = 'filled' if $groups > 0;
871             }
872             elsif ($class eq 'edge')
873             {
874 82 100 100     214 $out->{dir} = 'back' if $flow == 270 || $flow == 0;
875 82         159 my ($name,$style) = $self->_graphviz_remap_arrow_style('',
876             $self->attribute('edge','arrowstyle') );
877 82         143 $out->{$name} = $style;
878             }
879              
880 246         356 my $att = $self->_att_as_graphviz($out);
881              
882 246 50       739 $txt .= " $class [$att];\n" if $att ne '';
883             }
884              
885 82 50       138 $txt .= "\n" if $txt ne ''; # insert newline
886              
887             ###########################################################################
888             # output groups as subgraphs
889              
890             # insert the edges into the proper group
891 82 100       163 $self->_edges_into_groups() if $groups > 0;
892              
893             # output the groups (aka subclusters)
894 82         195 for my $group (ord_values $self->{groups})
895             {
896 14         23 $self->_order_group($group);
897             }
898 82         85 for my $group (sort { $a->{_order} cmp $b->{_order} } values %{$self->{groups}})
  4         5  
  82         147  
899             {
900 14   100     26 $txt .= $self->_as_graphviz_group($group) || '';
901             }
902              
903 82         170 my $root = $self->attribute('root');
904 82 50       127 $root = '' unless defined $root;
905              
906 82         70 my $count = 0;
907             # output nodes with attributes first, sorted by their name
908 82         52 for my $n (sort { $a->{name} cmp $b->{name} } values %{$self->{nodes}})
  179         248  
  82         242  
909             {
910 208 100       338 next if exists $n->{_p};
911             # skip nodes that are relativ to others (these are done as part
912             # of the HTML-like label of their parent)
913 190 50       287 next if $n->{origin};
914 190         273 my $att = $n->attributes_as_graphviz($root);
915 190 100       271 if ($att ne '')
916             {
917 124         153 $n->{_p} = undef; # mark as processed
918 124         92 $count++;
919 124         203 $txt .= " " . $n->as_graphviz_txt() . $att . "\n";
920             }
921             }
922              
923 82 100       136 $txt .= "\n" if $count > 0; # insert a newline
924              
925 82         180 my @nodes = $self->sorted_nodes();
926              
927             # output the edges
928 82         101 foreach my $n (@nodes)
929             {
930 208         418 my @out = $n->successors();
931 208         385 my $first = $n->as_graphviz_txt();
932 208 100 100     467 if ((@out == 0) && ( (scalar $n->predecessors() || 0) == 0))
      100        
933             {
934             # single node without any connections (unless already output)
935 12 0 33     25 $txt .= " " . $first . "\n" unless exists $n->{_p} || $n->{origin};
936             }
937             # for all outgoing connections
938 208         337 foreach my $other (reverse @out)
939             {
940             # in case there is more than one edge going from N to O
941 98         257 my @edges = $n->edges_to($other);
942 98         98 foreach my $e (@edges)
943             {
944 98 50       145 next if exists $e->{_p};
945 98         158 $txt .= $self->_generate_edge($e, ' ');
946             }
947             }
948             }
949              
950             # insert now edges between groups (clusters/subgraphs)
951              
952 82         130 foreach my $e (ord_values $self->{edges})
953             {
954             $txt .= $self->_generate_group_edge($e, ' ')
955             if $e->{from}->isa('Graph::Easy::Group') ||
956 98 50 33     577 $e->{to}->isa('Graph::Easy::Group');
957             }
958              
959             # clean up
960 82         143 for my $n ( ord_values( $self->{nodes}), ord_values( $self->{edges} ))
961             {
962 306         279 delete $n->{_p};
963             }
964 82         119 delete $self->{_graphviz_invis}; # invisible helper nodes for joints
965 82         78 delete $self->{_flip_edges};
966 82         65 delete $self->{_edge_type};
967              
968 82         340 $txt . "\n}\n"; # close the graph
969             }
970              
971             package Graph::Easy::Node;
972              
973             sub attributes_as_graphviz
974             {
975             # return the attributes of this node as text description
976 306     306 0 280 my ($self, $root) = @_;
977 306 100       429 $root = '' unless defined $root;
978              
979 306         215 my $att = '';
980 306         510 my $class = $self->class();
981              
982 306 50       534 return '' unless ref $self->{graph};
983              
984 306         240 my $g = $self->{graph};
985              
986             # get all attributes, excluding the class attributes
987 306         516 my $a = $self->raw_attributes();
988              
989             # add the attributes that are listed under "always":
990 306         261 my $attr = $self->{att};
991 306         214 my $base_class = $class; $base_class =~ s/\..*//;
  306         276  
992 306   66     573 my $list = $remap->{always}->{$class} || $remap->{always}->{$base_class};
993 306         313 for my $name (@$list)
994             {
995             # for speed, try to look it up directly
996              
997             # look if we have a code ref:
998 1640 100 100     3873 if ( ref($remap->{$base_class}->{$name}) ||
999             ref($remap->{all}->{$name}) )
1000             {
1001 1542         2294 $a->{$name} = $self->raw_attribute($name);
1002 1542 100       2313 if (!defined $a->{$name})
1003             {
1004 1366         2243 my $b_attr = $g->get_attribute($base_class,$name);
1005 1366         1981 my $c_attr = $g->get_attribute($class,$name);
1006 1366 100 66     5580 if (defined $b_attr && defined $c_attr && $b_attr ne $c_attr)
      100        
1007             {
1008 2         4 $a->{$name} = $c_attr;
1009 2 50       8 $a->{$name} = $b_attr unless defined $a->{$name};
1010             }
1011             }
1012             }
1013             else
1014             {
1015 98         126 $a->{$name} = $attr->{$name};
1016 98 100 66     290 $a->{$name} = $self->attribute($name) unless defined $a->{$name} && $a->{$name} ne 'inherit';
1017             }
1018             }
1019              
1020 306         621 $a = $g->_remap_attributes( $self, $a, $remap, 'noquote');
1021              
1022             # do not needlessly output labels:
1023             delete $a->{label} if !$self->isa('Graph::Easy::Edge') && # not an edge
1024 306 100 66     1932 exists $a->{label} && $a->{label} eq $self->{name};
      66        
1025              
1026             # generate HTML-like labels for nodes with children, but do so only
1027             # for the node which is not itself a child
1028 306 50 33     894 if (!$self->{origin} && $self->{children} && keys %{$self->{children}} > 0)
  6   66     21  
1029             {
1030             #print "Generating HTML-like label for $self->{name}\n";
1031 0         0 $a->{label} = $self->_html_like_label();
1032             # make Graphviz avoid the outer border
1033 0         0 $a->{shape} = 'none';
1034             }
1035              
1036             # bidirectional and undirected edges
1037 306 100       446 if ($self->{bidirectional})
1038             {
1039 1         3 delete $a->{dir};
1040 1         3 my ($n,$s) = Graph::Easy::_graphviz_remap_arrow_style(
1041             $self,'', $self->attribute('arrowstyle'));
1042 1         2 $a->{arrowhead} = $s;
1043 1         1 $a->{arrowtail} = $s;
1044             }
1045 306 100       394 if ($self->{undirected})
1046             {
1047 1         2 delete $a->{dir};
1048 1         1 $a->{arrowhead} = 'none';
1049 1         2 $a->{arrowtail} = 'none';
1050             }
1051              
1052 306 100       602 if (!$self->isa_cell())
1053             {
1054             # borderstyle: double:
1055 208         300 my $style = $self->attribute('borderstyle');
1056 208         358 my $w = $self->attribute('borderwidth');
1057 208 50 66     403 $a->{peripheries} = 2 if $style =~ /^double/ && $w > 0;
1058             }
1059              
1060             # For nodes with shape plaintext, set the fillcolor to the background of
1061             # the graph/group
1062 306   100     709 my $shape = $a->{shape} || 'rect';
1063 306 100 100     881 if ($class =~ /node/ && $shape eq 'plaintext')
1064             {
1065 3         8 my $p = $self->parent();
1066 3         7 $a->{fillcolor} = $p->attribute('fill');
1067 3 100       9 $a->{fillcolor} = 'white' if $a->{fillcolor} eq 'inherit';
1068             }
1069              
1070 306 100       775 $shape = $self->attribute('shape') unless $self->isa_cell();
1071              
1072             # for point-shaped nodes, include the point as label and set width/height
1073 306 100       391 if ($shape eq 'point')
1074             {
1075 1         472 require Graph::Easy::As_ascii; # for _u8 and point-style
1076              
1077 1         5 my $style = $self->_point_style(
1078             $self->attribute('pointshape'),
1079             $self->attribute('pointstyle') );
1080              
1081 1         2 $a->{label} = $style;
1082             # for point-shaped invisible nodes, set height/width = 0
1083 1 50       3 $a->{width} = 0, $a->{height} = 0 if $style eq '';
1084             }
1085 306 100       354 if ($shape eq 'invisible')
1086             {
1087 1         3 $a->{label} = ' ';
1088             }
1089              
1090 306 100 100     531 $a->{rank} = '0' if $root ne '' && $root eq $self->{name};
1091              
1092             # create the attributes as text:
1093 306         764 for my $atr (sort keys %$a)
1094             {
1095 530         454 my $v = $a->{$atr};
1096 530         417 $v =~ s/"/\\"/g; # '2"' => '2\"'
1097              
1098             # don't quote labels like "<
1099 530 50 66     805 if ($atr eq 'label' && $v =~ /^<
1100             {
1101 0         0 my $va = $v; $va =~ s/\\"/"/g; # unescape \"
  0         0  
1102 0         0 $att .= "$atr=$va, ";
1103 0         0 next;
1104             }
1105              
1106 530 100 66     1514 $v = '"' . $v . '"' if $v !~ /^[a-z0-9A-Z]+\z/
1107             || $atr eq 'URL'; # quote if nec.
1108              
1109             # convert "x-dot-foo" to "foo". Special case "K":
1110 530 50       358 my $name = $atr; $name =~ s/^x-dot-//; $name = 'K' if $name eq 'k';
  530         360  
  530         560  
1111              
1112 530         830 $att .= "$name=$v, ";
1113             }
1114 306         692 $att =~ s/,\s$//; # remove last ","
1115              
1116             # generate attribute text if nec.
1117 306 100       571 $att = ' [ ' . $att . ' ]' if $att ne '';
1118              
1119 306         663 $att;
1120             }
1121              
1122             sub _html_like_label
1123             {
1124             # Generate a HTML-like label from one node with its relative children
1125 0     0   0 my ($self) = @_;
1126              
1127 0         0 my $cells = {};
1128 0         0 my $rc = $self->_do_place(0,0, { cells => $cells, cache => {} } );
1129              
1130             #
Name2
1131             # ALIGN ="LEFT" BALIGN="LEFT" PORT="E4">Somewhere
test1
test
1132              
1133 0         0 my $label = '<'; '; $old_x = 0; '; ';
1134              
1135 0         0 my $old_y = 0; my $old_x = 0;
  0         0  
1136             # go through all children, and sort them by Y then X coordinate
1137 0         0 my @cells = ();
1138 0         0 for my $cell (sort {
1139 0         0 my ($ax,$ay) = split /,/,$a;
1140 0         0 my ($bx,$by) = split /,/,$b;
1141 0 0       0 $ay <=> $by or $ax <=> $bx; } keys %$cells )
1142             {
1143             #print "cell $cell\n";
1144 0         0 my ($x,$y) = split /,/, $cell;
1145 0 0       0 if ($y > $old_y)
1146             {
1147 0         0 $label .= '
  0         0  
1148             }
1149 0         0 my $n = $cells->{$cell};
1150 0         0 my $l = $n->label();
1151 0         0 $l =~ s/\\n//g;
1152 0         0 my $portname = $n->{autosplit_portname};
1153 0 0       0 $portname = $n->label() unless defined $portname;
1154 0         0 my $name = $self->{name};
1155 0         0 $portname =~ s/\"/\\"/g; # quote "
1156 0         0 $name =~ s/\"/\\"/g; # quote "
1157             # store the "nodename:portname" combination for potential edges
1158 0         0 $n->{_graphviz_portname} = '"' . $name . '":"' . $portname . '"';
1159 0 0       0 if (($x - $old_x) > 0)
1160             {
1161             # need some spacers
1162 0         0 $label .= '
1163             }
1164 0         0 $label .= '' . $l . '
1165 0         0 $old_y = $y + $n->{cy}; $old_x = $x + $n->{cx};
  0         0  
1166             }
1167              
1168             # return "<>"
1169 0         0 $label . '
>';
1170             }
1171              
1172             sub _graphviz_point
1173             {
1174             # return the node as the target/source of an edge
1175             # either "name", or "name:port"
1176 196     196   142 my ($n) = @_;
1177              
1178 196 50       229 return $n->{_graphviz_portname} if exists $n->{_graphviz_portname};
1179              
1180 196         208 $n->as_graphviz_txt();
1181             }
1182              
1183             sub as_graphviz_txt
1184             {
1185             # return the node itself (w/o attributes) as graphviz representation
1186 547     547 1 391 my $self = shift;
1187              
1188 547         437 my $name = $self->{name};
1189              
1190             # escape special chars in name (including doublequote!)
1191 547         596 $name =~ s/([\[\]\(\)\{\}"])/\\$1/g;
1192              
1193             # quote if necessary:
1194             # 2, A, A2, "2A", "2 A" etc
1195 547 100 100     2310 $name = '"' . $name . '"' if $name !~ /^([a-zA-Z_]+|\d+)\z/ ||
1196             $name =~ /^(subgraph|graph|node|edge|strict)\z/i; # reserved keyword
1197              
1198 547         846 $name;
1199             }
1200              
1201             1;
1202             __END__