File Coverage

lib/Graph/Easy/Node.pm
Criterion Covered Total %
statement 832 932 89.2
branch 465 568 81.8
condition 156 192 81.2
subroutine 74 77 96.1
pod 45 45 100.0
total 1572 1814 86.6


line stmt bran cond sub pod time code
1             #############################################################################
2             # Represents one node in a Graph::Easy graph.
3             #
4             # (c) by Tels 2004-2008. Part of Graph::Easy.
5             #############################################################################
6              
7             package Graph::Easy::Node;
8              
9             $VERSION = '0.76';
10              
11 48     48   45691 use Graph::Easy::Base;
  48         65  
  48         1134  
12 48     48   2924 use Graph::Easy::Attributes;
  48         194  
  48         2315  
13             @ISA = qw/Graph::Easy::Base/;
14              
15 48     48   11181 use Graph::Easy::Util qw(ord_values);
  48         64  
  48         2391  
16              
17             # to map "arrow-shape" to "arrowshape"
18             my $att_aliases;
19              
20 48     48   179 use strict;
  48         49  
  48         680  
21 48     48   127 use warnings;
  48         42  
  48         953  
22 48     48   171 use constant isa_cell => 0;
  48         36  
  48         52855  
23              
24             sub _init
25             {
26             # Generic init routine, to be overridden in subclasses.
27 1669     1669   1642 my ($self,$args) = @_;
28              
29 1669         3350 $self->{name} = 'Node #' . $self->{id};
30              
31 1669         1927 $self->{att} = { };
32 1669         1842 $self->{class} = 'node'; # default class
33              
34 1669         3896 foreach my $k (sort keys %$args)
35             {
36 1642 50       4989 if ($k !~ /^(label|name)\z/)
37             {
38 0         0 require Carp;
39 0         0 Carp::confess ("Invalid argument '$k' passed to Graph::Easy::Node->new()");
40             }
41 1642 100       3726 $self->{$k} = $args->{$k} if $k eq 'name';
42 1642 100       2813 $self->{att}->{$k} = $args->{$k} if $k eq 'label';
43             }
44              
45             # These are undef (to save memory) until needed:
46             # $self->{children} = {};
47             # $self->{dx} = 0; # relative to no other node
48             # $self->{dy} = 0;
49             # $self->{origin} = undef; # parent node (for relative placement)
50             # $self->{group} = undef;
51             # $self->{parent} = $graph or $group;
52             # Mark as not yet laid out:
53             # $self->{x} = 0;
54             # $self->{y} = 0;
55              
56 1669         3815 $self;
57             }
58              
59             my $merged_borders =
60             {
61             'dotteddashed' => 'dot-dash',
62             'dasheddotted' => 'dot-dash',
63             'double-dashdouble' => 'double',
64             'doubledouble-dash' => 'double',
65             'doublesolid' => 'double',
66             'soliddouble' => 'double',
67             'dotteddot-dash' => 'dot-dash',
68             'dot-dashdotted' => 'dot-dash',
69             };
70              
71             sub _collapse_borders
72             {
73             # Given a right border from node one, and the left border of node two,
74             # return what border we need to draw on node two:
75 86     86   108 my ($self, $one, $two, $swapem) = @_;
76              
77 86 50       146 ($one,$two) = ($two,$one) if $swapem;
78              
79 86 50       131 $one = 'none' unless $one;
80 86 50       127 $two = 'none' unless $two;
81              
82             # If the border of the left/top node is defined, we don't draw the
83             # border of the right/bottom node.
84 86 50 66     224 return 'none' if $one ne 'none' || $two ne 'none';
85              
86             # otherwise, we draw simple the right border
87 0         0 $two;
88             }
89              
90             sub _merge_borders
91             {
92 123     123   138 my ($self, $one, $two) = @_;
93              
94 123 50       178 $one = 'none' unless $one;
95 123 50       179 $two = 'none' unless $two;
96              
97             # "nonenone" => "none" or "dotteddotted" => "dotted"
98 123 100       256 return $one if $one eq $two;
99              
100             # none + solid == solid + none == solid
101 5 100       13 return $one if $two eq 'none';
102 4 100       9 return $two if $one eq 'none';
103              
104 3         5 for my $b (qw/broad wide bold double solid/)
105             {
106             # the stronger one overrides the weaker one
107 13 100 100     41 return $b if $one eq $b || $two eq $b;
108             }
109              
110 0         0 my $both = $one . $two;
111 0 0       0 return $merged_borders->{$both} if exists $merged_borders->{$both};
112              
113             # fallback
114 0         0 $two;
115             }
116              
117             sub _border_to_draw
118             {
119             # Return the border style we need to draw, taking the shape (none) into
120             # account
121 1271     1271   1245 my ($self, $shape) = @_;
122              
123 1271         1243 my $cache = $self->{cache};
124              
125 1271 100       2379 return $cache->{border_style} if defined $cache->{border_style};
126              
127 1062 100       1552 $shape = $self->{att}->{shape} unless defined $shape;
128 1062 100       1736 $shape = $self->attribute('shape') unless defined $shape;
129              
130 1062         1480 $cache->{border_style} = $self->{att}->{borderstyle};
131 1062 100       2815 $cache->{border_style} = $self->attribute('borderstyle') unless defined $cache->{border_style};
132 1062 100       2656 $cache->{border_style} = 'none' if $shape =~ /^(none|invisible)\z/;
133 1062         1549 $cache->{border_style};
134             }
135              
136             sub _border_styles
137             {
138             # Return the four border styles (right, bottom, left, top). This takes
139             # into account the neighbouring nodes and their borders, so that on
140             # ASCII output the borders can be properly collapsed.
141 1062     1062   1090 my ($self, $border, $collapse) = @_;
142              
143 1062         973 my $cache = $self->{cache};
144              
145             # already computed values?
146 1062 50       1753 return if defined $cache->{left_border};
147              
148 1062         1334 $cache->{left_border} = $border;
149 1062         1267 $cache->{top_border} = $border;
150 1062         1303 $cache->{right_border} = $border;
151 1062         1406 $cache->{bottom_border} = $border;
152              
153 1062 50       1401 return unless $collapse;
154              
155             # print STDERR " border_styles: $self->{name} border=$border\n";
156              
157 1062         835 my $EM = 14;
158 1062         2110 my $border_width = Graph::Easy::_border_width_in_pixels($self,$EM);
159              
160             # convert overly broad borders to the correct style
161 1062 100       2134 $border = 'bold' if $border_width > 2;
162 1062 100 66     2365 $border = 'broad' if $border_width > $EM * 0.2 && $border_width < $EM * 0.75;
163 1062 50       1582 $border = 'wide' if $border_width >= $EM * 0.75;
164              
165             # XXX TODO
166             # handle different colors, too:
167             # my $color = $self->color_attribute('bordercolor');
168              
169             # Draw border on A (left), and C (left):
170             #
171             # +---+
172             # B | A | C
173             # +---+
174              
175             # Ditto, plus C's border:
176             #
177             # +---+---+
178             # B | A | C |
179             # +---+---+
180             #
181              
182             # If no left neighbour, draw border normally
183              
184             # XXX TODO: ->{parent} ?
185 1062   33     2481 my $parent = $self->{parent} || $self->{graph};
186 1062 100       1931 return unless ref $parent;
187              
188 1060         1010 my $cells = $parent->{cells};
189 1060 50       1388 return unless ref $cells;
190              
191 1060         1071 my $x = $self->{x}; my $y = $self->{y};
  1060         966  
192              
193 1060         922 $x -= 1; my $left = $cells->{"$x,$y"};
  1060         1998  
194 1060         942 $x += 1; $y-= 1; my $top = $cells->{"$x,$y"};
  1060         921  
  1060         1221  
195 1060         721 $x += 1; $y += 1; my $right = $cells->{"$x,$y"};
  1060         770  
  1060         1193  
196 1060         760 $x -= 1; $y += 1; my $bottom = $cells->{"$x,$y"};
  1060         775  
  1060         1233  
197              
198             # where to store the result
199 1060         1826 my @where = ('left', 'top', 'right', 'bottom');
200             # need to swap arguments to _collapse_borders()?
201 1060         1202 my @swapem = (0, 0, 1, 1);
202              
203 1060         1251 for my $other ($left, $top, $right, $bottom)
204             {
205 4240         3135 my $side = shift @where;
206 4240         2916 my $swap = shift @swapem;
207              
208             # see if we have a (visible) neighbour on the left side
209 4240 100 100     16085 if (ref($other) &&
      100        
      100        
210             !$other->isa('Graph::Easy::Edge') &&
211             !$other->isa_cell() &&
212             !$other->isa('Graph::Easy::Node::Empty'))
213             {
214 209 100       365 $other = $other->{node} if ref($other->{node});
215              
216             # print STDERR "$side node $other ", $other->_border_to_draw(), " vs. $border (swap $swap)\n";
217              
218 209 50       388 if ($other->attribute('shape') ne 'invisible')
219             {
220             # yes, so take its border style
221 209         127 my $result;
222 209 100       295 if ($swap)
223             {
224 123         225 $result = $self->_merge_borders($other->_border_to_draw(), $border);
225             }
226             else
227             {
228 86         187 $result = $self->_collapse_borders($border, $other->_border_to_draw());
229             }
230 209         478 $cache->{$side . '_border'} = $result;
231              
232             # print STDERR "# result: $result\n";
233             }
234             }
235             }
236             }
237              
238             sub _correct_size
239             {
240             # Correct {w} and {h} after parsing. This is a fallback in case
241             # the output specific routines (_correct_site_ascii() etc) do
242             # not exist.
243 1078     1078   832 my $self = shift;
244              
245 1078 100       1874 return if defined $self->{w};
246              
247 1063         2062 my $shape = $self->attribute('shape');
248              
249 1063 100       2009 if ($shape eq 'point')
    100          
250             {
251 8         12 $self->{w} = 5;
252 8         9 $self->{h} = 3;
253 8         17 my $style = $self->attribute('pointstyle');
254 8         18 my $shape = $self->attribute('pointshape');
255 8 100 66     30 if ($style eq 'invisible' || $shape eq 'invisible')
256             {
257 1         2 $self->{w} = 0; $self->{h} = 0; return;
  1         1  
  1         2  
258             }
259             }
260             elsif ($shape eq 'invisible')
261             {
262 3         6 $self->{w} = 3;
263 3         5 $self->{h} = 3;
264             }
265             else
266             {
267 1052         1711 my ($w,$h) = $self->dimensions();
268 1052         1504 $self->{h} = $h;
269 1052         1360 $self->{w} = $w + 2;
270             }
271              
272 1062         2044 my $border = $self->_border_to_draw($shape);
273              
274 1062         1864 $self->_border_styles($border, 'collapse');
275              
276             # print STDERR "# $self->{name} $self->{w} $self->{h} $shape\n";
277             # use Data::Dumper; print Dumper($self->{cache});
278              
279 1062 100       1768 if ($shape !~ /^(invisible|point)/)
280             {
281 1052 100       2154 $self->{w} ++ if $self->{cache}->{right_border} ne 'none';
282 1052 100       1706 $self->{w} ++ if $self->{cache}->{left_border} ne 'none';
283 1052 100       1797 $self->{h} ++ if $self->{cache}->{top_border} ne 'none';
284 1052 100       1569 $self->{h} ++ if $self->{cache}->{bottom_border} ne 'none';
285              
286 1052 100 66     1886 $self->{h} += 2 if $border eq 'none' && $shape !~ /^(invisible|point)/;
287             }
288              
289 1062         1855 $self;
290             }
291              
292             sub _unplace
293             {
294             # free the cells this node occupies from $cells
295 0     0   0 my ($self,$cells) = @_;
296              
297 0         0 my $x = $self->{x}; my $y = $self->{y};
  0         0  
298 0         0 delete $cells->{"$x,$y"};
299 0         0 $self->{x} = undef;
300 0         0 $self->{y} = undef;
301 0         0 $self->{cache} = {};
302              
303 0 0       0 $self->_calc_size() unless defined $self->{cx};
304              
305 0 0       0 if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
306             {
307 0         0 for my $ax (1..$self->{cx})
308             {
309 0         0 my $sx = $x + $ax - 1;
310 0         0 for my $ay (1..$self->{cy})
311             {
312 0         0 my $sy = $y + $ay - 1;
313             # free cell
314 0         0 delete $cells->{"$sx,$sy"};
315             }
316             }
317             } # end handling multi-celled node
318              
319             # unplace all edges leading to/from this node, too:
320 0         0 for my $e (ord_values ( $self->{edges} ))
321             {
322 0         0 $e->_unplace($cells);
323             }
324              
325 0         0 $self;
326             }
327              
328             sub _mark_as_placed
329             {
330             # for creating an action on the action stack we also need to recursively
331             # mark all our children as already placed:
332 583     583   445 my ($self) = @_;
333              
334 48     48   261 no warnings 'recursion';
  48         346  
  48         4211  
335              
336 583         421 delete $self->{_todo};
337              
338 583         922 for my $child (ord_values ( $self->{children} ))
339             {
340 382         500 $child->_mark_as_placed();
341             }
342 583         739 $self;
343             }
344              
345             sub _place_children
346             {
347             # recursively place node and its children
348 227     227   215 my ($self, $x, $y, $parent) = @_;
349              
350 48     48   170 no warnings 'recursion';
  48         60  
  48         141335  
351              
352 227 100       300 return 0 unless $self->_check_place($x,$y,$parent);
353              
354 224 50       317 print STDERR "# placing children of $self->{name} based on $x,$y\n" if $self->{debug};
355              
356 224         365 for my $child (ord_values ( $self->{children} ))
357             {
358             # compute place of children (depending on whether we are multicelled or not)
359              
360 153 100       265 my $dx = $child->{dx} > 0 ? $self->{cx} - 1 : 0;
361 153 100       216 my $dy = $child->{dy} > 0 ? $self->{cy} - 1 : 0;
362              
363 153         342 my $rc = $child->_place_children($x + $dx + $child->{dx},$y + $dy + $child->{dy},$parent);
364 153 100       297 return $rc if $rc == 0;
365             }
366 223         363 $self->_place($x,$y,$parent);
367             }
368              
369             sub _place
370             {
371             # place this node at the requested position (without checking)
372 1137     1137   1162 my ($self, $x, $y, $parent) = @_;
373              
374 1137         1058 my $cells = $parent->{cells};
375 1137         1229 $self->{x} = $x;
376 1137         969 $self->{y} = $y;
377 1137         2008 $cells->{"$x,$y"} = $self;
378              
379             # store our position if we are the first node in that rank
380 1137   100     1887 my $r = abs($self->{rank} || 0);
381 1137   100     1761 my $what = $parent->{_rank_coord} || 'x'; # 'x' or 'y'
382             $parent->{_rank_pos}->{ $r } = $self->{$what}
383 1137 100       2538 unless defined $parent->{_rank_pos}->{ $r };
384              
385             # a multi-celled node will be stored like this:
386             # [ node ] [ filler ]
387             # [ filler ] [ filler ]
388             # [ filler ] [ filler ] etc.
389              
390             # $self->_calc_size() unless defined $self->{cx};
391              
392 1137 100       2006 if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
393             {
394 30         51 for my $ax (1..$self->{cx})
395             {
396 74         67 my $sx = $x + $ax - 1;
397 74         96 for my $ay (1..$self->{cy})
398             {
399 124 100 100     321 next if $ax == 1 && $ay == 1; # skip left-upper most cell
400 94         79 my $sy = $y + $ay - 1;
401              
402             # We might even get away with creating only one filler cell
403             # although then its "x" and "y" values would be "wrong".
404              
405 94         265 my $filler =
406             Graph::Easy::Node::Cell->new ( node => $self, x => $sx, y => $sy );
407 94         204 $cells->{"$sx,$sy"} = $filler;
408             }
409             }
410             } # end handling of multi-celled node
411              
412 1137         1845 $self->_update_boundaries($parent);
413              
414 1137         4740 1; # did place us
415             }
416              
417             sub _check_place
418             {
419             # chack that a node can be placed at $x,$y (w/o checking its children)
420 227     227   733 my ($self,$x,$y,$parent) = @_;
421              
422 227         176 my $cells = $parent->{cells};
423              
424             # node cannot be placed here
425 227 100       439 return 0 if exists $cells->{"$x,$y"};
426              
427 224 100       317 $self->_calc_size() unless defined $self->{cx};
428              
429 224 100       353 if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
430             {
431 10         23 for my $ax (1..$self->{cx})
432             {
433 26         24 my $sx = $x + $ax - 1;
434 26         34 for my $ay (1..$self->{cy})
435             {
436 38         29 my $sy = $y + $ay - 1;
437             # node cannot be placed here
438 38 50       75 return 0 if exists $cells->{"$sx,$sy"};
439             }
440             }
441             }
442 224         343 1; # can place it here
443             }
444              
445             sub _do_place
446             {
447             # Tries to place the node at position ($x,$y) by checking that
448             # $cells->{"$x,$y"} is still free. If the node belongs to a cluster,
449             # checks all nodes of the cluster (and when all of them can be
450             # placed simultaneously, does so).
451             # Returns true if the operation succeeded, otherwise false.
452 1084     1084   1668 my ($self,$x,$y,$parent) = @_;
453              
454 1084         1117 my $cells = $parent->{cells};
455              
456             # inlined from _check() for speed reasons:
457              
458             # node cannot be placed here
459 1084 100       2413 return 0 if exists $cells->{"$x,$y"};
460              
461 988 100       1533 $self->_calc_size() unless defined $self->{cx};
462              
463 988 100       1788 if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
464             {
465 27         68 for my $ax (1..$self->{cx})
466             {
467 68         57 my $sx = $x + $ax - 1;
468 68         72 for my $ay (1..$self->{cy})
469             {
470 114         102 my $sy = $y + $ay - 1;
471             # node cannot be placed here
472 114 50       203 return 0 if exists $cells->{"$sx,$sy"};
473             }
474             }
475             }
476              
477 988         766 my $children = 0;
478 988 100       1613 $children = scalar keys %{$self->{children}} if $self->{children};
  987         1367  
479              
480             # relativ to another, or has children (relativ to us)
481 988 100 100     3346 if (defined $self->{origin} || $children > 0)
482             {
483             # The coordinates of the origin node. Because 'dx' and 'dy' give
484             # our distance from the origin, we can compute the origin by doing
485             # "$x - $dx"
486              
487 74         116 my $grandpa = $self; my $ox = 0; my $oy = 0;
  74         68  
  74         67  
488             # Find our grandparent (e.g. the root of origin chain), and the distance
489             # from $x,$y to it:
490 74 100       157 ($grandpa,$ox,$oy) = $self->find_grandparent() if $self->{origin};
491              
492             # Traverse all children and check their places, place them if poss.
493             # This will also place ourselves, because we are a grandchild of $grandpa
494 74         202 return $grandpa->_place_children($x + $ox,$y + $oy,$parent);
495             }
496              
497             # finally place this node at the requested position
498 914         1540 $self->_place($x,$y,$parent);
499             }
500              
501             #############################################################################
502              
503             sub _wrapped_label
504             {
505             # returns the label wrapped automatically to use the least space
506 8     8   12 my ($self, $label, $align, $wrap) = @_;
507              
508 8 100       19 return (@{$self->{cache}->{label}}) if $self->{cache}->{label};
  3         10  
509              
510             # XXX TODO: handle "paragraphs"
511 5         17 $label =~ s/\\(n|r|l|c)/ /g; # replace line splits by spaces
512              
513             # collapse multiple spaces
514 5         31 $label =~ s/\s+/ /g;
515              
516             # find out where to wrap
517 5 50       11 if ($wrap eq 'auto')
518             {
519 0         0 $wrap = int(sqrt(length($label)) * 1.4);
520             }
521 5 50       13 $wrap = 2 if $wrap < 2;
522              
523             # run through the text and insert linebreaks
524 5         6 my $i = 0;
525 5         5 my $line_len = 0;
526 5         5 my $last_space = 0;
527 5         6 my $last_hyphen = 0;
528 5         7 my @lines;
529 5         14 while ($i < length($label))
530             {
531 157         107 my $c = substr($label,$i,1);
532 157 100       179 $last_space = $i if $c eq ' ';
533 157 100       168 $last_hyphen = $i if $c eq '-';
534 157         92 $line_len ++;
535 157 100 100     231 if ($line_len >= $wrap && ($last_space != 0 || $last_hyphen != 0))
      66        
536             {
537             # print STDERR "# wrap at $line_len\n";
538              
539 14         12 my $w = $last_space; my $replace = '';
  14         11  
540 14 100       18 if ($last_hyphen > $last_space)
541             {
542 1         2 $w = $last_hyphen; $replace = '-';
  1         2  
543             }
544              
545             # print STDERR "# wrap at $w\n";
546              
547             # "foo bar-baz" => "foo bar" (lines[0]) and "baz" (label afterwards)
548              
549             # print STDERR "# first part '". substr($label, 0, $w) . "'\n";
550              
551 14         30 push @lines, substr($label, 0, $w) . $replace;
552 14         24 substr($label, 0, $w+1) = '';
553             # reset counters
554 14         11 $line_len = 0;
555 14         9 $i = 0;
556 14         9 $last_space = 0;
557 14         7 $last_hyphen = 0;
558 14         27 next;
559             }
560 143         168 $i++;
561             }
562             # handle what is left over
563 5 100       14 push @lines, $label if $label ne '';
564              
565             # generate the align array
566 5         4 my @aligns;
567 5         8 my $al = substr($align,0,1);
568 5         14 for my $i (0.. scalar @lines)
569             {
570 23         26 push @aligns, $al;
571             }
572             # cache the result to avoid costly recomputation
573 5         16 $self->{cache}->{label} = [ \@lines, \@aligns ];
574 5         18 (\@lines, \@aligns);
575             }
576              
577             sub _aligned_label
578             {
579             # returns the label lines and for each one the alignment l/r/c
580 4229     4229   4200 my ($self, $align, $wrap) = @_;
581              
582 4229 100       5738 $align = 'center' unless $align;
583 4229 100       9561 $wrap = $self->attribute('textwrap') unless defined $wrap;
584              
585 4229         7393 my $name = $self->label();
586              
587 4229 100       6355 return $self->_wrapped_label($name,$align,$wrap) unless $wrap eq 'none';
588              
589 4221         3054 my (@lines,@aligns);
590 4221         4715 my $al = substr($align,0,1);
591 4221         3066 my $last_align = $al;
592              
593             # split up each line from the front
594 4221         6080 while ($name ne '')
595             {
596 2518         12997 $name =~ s/^(.*?([^\\]|))(\z|\\(n|r|l|c))//;
597 2518         3584 my $part = $1;
598 2518   100     7356 my $a = $3 || '\n';
599              
600 2518         2338 $part =~ s/\\\|/\|/g; # \| => |
601 2518         2489 $part =~ s/\\\\/\\/g; # '\\' to '\'
602 2518         3353 $part =~ s/^\s+//; # remove spaces at front
603 2518         3327 $part =~ s/\s+\z//; # remove spaces at end
604 2518         3798 $a =~ s/\\//; # \n => n
605 2518 100       4400 $a = $al if $a eq 'n';
606              
607 2518         2957 push @lines, $part;
608 2518         2543 push @aligns, $last_align;
609              
610 2518         4397 $last_align = $a;
611             }
612              
613             # XXX TODO: should remove empty lines at start/end?
614 4221         10238 (\@lines, \@aligns);
615             }
616              
617             #############################################################################
618             # as_html conversion and helper functions related to that
619              
620             my $remap = {
621             node => {
622             align => undef,
623             background => undef,
624             basename => undef,
625             border => undef,
626             borderstyle => undef,
627             borderwidth => undef,
628             bordercolor => undef,
629             columns => undef,
630             fill => 'background',
631             origin => undef,
632             offset => undef,
633             pointstyle => undef,
634             pointshape => undef,
635             rows => undef,
636             size => undef,
637             shape => undef,
638             },
639             edge => {
640             fill => undef,
641             border => undef,
642             },
643             all => {
644             align => 'text-align',
645             autolink => undef,
646             autotitle => undef,
647             comment => undef,
648             fontsize => undef,
649             font => 'font-family',
650             flow => undef,
651             format => undef,
652             label => undef,
653             link => undef,
654             linkbase => undef,
655             style => undef,
656             textstyle => undef,
657             title => undef,
658             textwrap => \&Graph::Easy::_remap_text_wrap,
659             group => undef,
660             },
661             };
662              
663             sub _extra_params
664             {
665             # return text with a leading " ", that will be appended to "td" when
666             # generating HTML
667 77     77   82 '';
668             }
669              
670             # XXX TODO: ?
671             my $pod = {
672             B => [ '', '' ],
673             O => [ '', '' ],
674             S => [ '', '' ],
675             U => [ '', '' ],
676             C => [ '', '' ],
677             I => [ '', '' ],
678             };
679              
680             sub _convert_pod
681             {
682 0     0   0 my ($self, $type, $text) = @_;
683              
684 0 0       0 my $t = $pod->{$type} or return $text;
685              
686             # "" . "text" . ""
687 0         0 $t->[0] . $text . $t->[1];
688             }
689              
690             sub _label_as_html
691             {
692             # Build the text from the lines, by inserting for each break
693             # Also align each line, and if nec., convert B to bold.
694 124     124   108 my ($self) = @_;
695              
696 124         172 my $align = $self->attribute('align');
697 124         206 my $text_wrap = $self->attribute('textwrap');
698              
699 124         109 my ($lines,$aligns);
700 124 50       158 if ($text_wrap eq 'auto')
701             {
702             # set "white-space: nowrap;" in CSS and ignore linebreaks in label
703 0         0 $lines = [ $self->label() ];
704 0         0 $aligns = [ substr($align,0,1) ];
705             }
706             else
707             {
708 124         260 ($lines,$aligns) = $self->_aligned_label($align,$text_wrap);
709             }
710              
711             # Since there is no "float: center;" in CSS, we must set the general
712             # text-align to center when we encounter any \c and the default is
713             # left or right:
714              
715 124         119 my $switch_to_center = 0;
716 124 100       201 if ($align ne 'center')
717             {
718 27         28 local $_;
719 27         56 $switch_to_center = grep /^c/, @$aligns;
720             }
721              
722 124 100       180 $align = 'center' if $switch_to_center;
723 124         138 my $a = substr($align,0,1); # center => c
724              
725 124         225 my $format = $self->attribute('format');
726              
727 124         102 my $name = '';
728 124         100 my $i = 0;
729 124         216 while ($i < @$lines)
730             {
731 93         83 my $line = $lines->[$i];
732 93         82 my $al = $aligns->[$i];
733              
734             # This code below will not handle B due to the
735             # line break. Also, nesting does not work due to returned "<" and ">".
736              
737 93 50       113 if ($format eq 'pod')
738             {
739             # first inner-most, then go outer until there are none left
740 0         0 $line =~ s/([BOSUCI])<([^<>]+)>/ $self->_convert_pod($1,$2);/eg
  0         0  
741             while ($line =~ /[BOSUCI]<[^<>]+>/)
742             }
743             else
744             {
745 93         90 $line =~ s/&/&/g; # quote &
746 93         66 $line =~ s/>/>/g; # quote >
747 93         65 $line =~ s/
748 93         93 $line =~ s/\\\\/\\/g; # "\\" to "\"
749             }
750              
751             # insert a span to align the line unless the default already covers it
752 93 100       134 $line = '' . $line . ''
753             if $a ne $al;
754 93         138 $name .= '
' . $line;
755              
756 93         159 $i++; # next line
757             }
758 124         231 $name =~ s/^
//; # remove first
759              
760 124         343 ($name, $switch_to_center);
761             }
762              
763             sub quoted_comment
764             {
765             # Comment of this object, quoted suitable as to be embedded into HTML/SVG
766 197     197 1 164 my $self = shift;
767              
768 197         301 my $cmt = $self->attribute('comment');
769 197 100       273 if ($cmt ne '')
770             {
771 6         8 $cmt =~ s/&/&/g;
772 6         6 $cmt =~ s/
773 6         12 $cmt =~ s/>/>/g;
774 6         7 $cmt = '\n";
775             }
776              
777 197         691 $cmt;
778             }
779              
780             sub as_html
781             {
782             # return node as HTML
783 77     77 1 88 my ($self) = @_;
784              
785 77         65 my $shape = 'rect';
786 77 100       262 $shape = $self->attribute('shape') unless $self->isa_cell();
787              
788 77 50       124 if ($shape eq 'edge')
789             {
790 0         0 my $edge = Graph::Easy::Edge->new();
791 0         0 my $cell = Graph::Easy::Edge::Cell->new( edge => $edge );
792 0         0 $cell->{w} = $self->{w};
793 0         0 $cell->{h} = $self->{h};
794 0         0 $cell->{att}->{label} = $self->label();
795             $cell->{type} =
796 0         0 Graph::Easy::Edge::Cell->EDGE_HOR +
797             Graph::Easy::Edge::Cell->EDGE_LABEL_CELL;
798 0         0 return $cell->as_html();
799             }
800              
801 77         125 my $extra = $self->_extra_params();
802 77         135 my $taga = "td$extra";
803 77         69 my $tagb = 'td';
804              
805 77         88 my $id = $self->{graph}->{id};
806 77         61 my $a = $self->{att};
807 77         57 my $g = $self->{graph};
808              
809 77         114 my $class = $self->class();
810              
811             # how many rows/columns will this node span?
812 77   100     212 my $rs = ($self->{cy} || 1) * 4;
813 77   100     145 my $cs = ($self->{cx} || 1) * 4;
814              
815             # shape: invisible; must result in an empty cell
816 77 100 66     144 if ($shape eq 'invisible' && $class ne 'node.anon')
817             {
818 6         25 return " <$taga colspan=$cs rowspan=$rs style=\"border: none; background: inherit;\">\n";
819             }
820              
821 71         63 my $c = $class; $c =~ s/\./_/g; # node.city => node_city
  71         116  
822              
823 71         147 my $html = " <$taga colspan=$cs rowspan=$rs##class####style##";
824              
825 71         127 my $title = $self->title();
826 71         77 $title =~ s/'//g; # replace quotation marks
827              
828 71 100 66     155 $html .= " title='$title'" if $title ne '' && $shape ne 'img'; # add mouse-over title
829              
830 71         51 my ($name, $switch_to_center);
831              
832 71 50       138 if ($shape eq 'point')
    50          
833             {
834 0         0 require Graph::Easy::As_ascii; # for _u8 and point-style
835              
836 0         0 local $self->{graph}->{_ascii_style} = 1; # use utf-8
837 0         0 $name = $self->_point_style( $self->attribute('pointshape'), $self->attribute('pointstyle') );
838             }
839             elsif ($shape eq 'img')
840             {
841             # take the label as the URL, but escape critical characters
842 0         0 $name = $self->label();
843 0         0 $name =~ s/\s/\+/g; # space
844 0         0 $name =~ s/'/%27/g; # replace quotation marks
845 0         0 $name =~ s/[\x0d\x0a]//g; # remove 0x0d0x0a and similar
846 0 0       0 my $t = $title; $t = $name if $t eq '';
  0         0  
847 0         0 $name = "$t";
848             }
849             else
850             {
851 71         128 ($name,$switch_to_center) = $self->_label_as_html();
852             }
853              
854             # if the label is "", the link wouldn't be clickable
855 71 100       86 my $link = ''; $link = $self->link() unless $name eq '';
  71         270  
856              
857             # the attributes in $out will be applied to either the TD, or the inner DIV,
858             # unless if we have a link, then most of them will be moved to the A HREF
859 71         153 my $att = $self->raw_attributes();
860 71         172 my $out = $self->{graph}->_remap_attributes( $self, $att, $remap, 'noquote', 'encode', 'remap_colors');
861              
862 71 100       107 $out->{'text-align'} = 'center' if $switch_to_center;
863              
864             # only for nodes, not for edges
865 71 100       289 if (!$self->isa('Graph::Easy::Edge'))
866             {
867 69         127 my $bc = $self->attribute('bordercolor');
868 69         120 my $bw = $self->attribute('borderwidth');
869 69         129 my $bs = $self->attribute('borderstyle');
870              
871 69         142 $out->{border} = Graph::Easy::_border_attribute_as_html( $bs, $bw, $bc );
872              
873             # we need to specify the border again for the inner div
874 69 100       132 if ($shape !~ /(rounded|ellipse|circle)/)
875             {
876 61         125 my $DEF = $self->default_attribute('border');
877              
878 61 100 66     321 delete $out->{border} if $out->{border} =~ /^\s*\z/ || $out->{border} eq $DEF;
879             }
880              
881 69 50 66     131 delete $out->{border} if $class eq 'node.anon' && $out->{border} && $out->{border} eq 'none';
      66        
882             }
883              
884             # we compose the inner part as $inner_start . $label . $inner_end:
885 71         66 my $inner_start = '';
886 71         59 my $inner_end = '';
887              
888 71 100       112 if ($shape =~ /(rounded|ellipse|circle)/)
889             {
890             # set the fill on the inner part, but the background and no border on the :
891 8         9 my $inner_style = '';
892 8         16 my $fill = $self->color_attribute('fill');
893 8 50       18 $inner_style = 'background:' . $fill if $fill;
894 8 50       19 $inner_style .= ';border:' . $out->{border} if $out->{border};
895 8         21 $inner_style =~ s/;\s?\z$//; # remove '; ' at end
896              
897 8         7 delete $out->{background};
898 8         9 delete $out->{border};
899              
900 8         9 my $td_style = '';
901 8         8 $td_style = ' style="border: none;';
902 8         12 my $bg = $self->color_attribute('background');
903 8         12 $td_style .= "background: $bg\"";
904              
905 8         23 $html =~ s/##style##/$td_style/;
906              
907 8         7 $inner_end = '';
908 8 100       11 my $c = substr($shape, 0, 1); $c = 'c' if $c eq 'e'; # 'r' or 'c'
  8         15  
909              
910 8         16 my ($w,$h) = $self->dimensions();
911              
912 8 100       14 if ($shape eq 'circle')
913             {
914             # set both to the biggest size to enforce a circle shape
915 1         1 my $r = $w;
916 1 50       3 $r = $h if $h > $w;
917 1         0 $w = $r; $h = $r;
  1         2  
918             }
919              
920 8 50       56 $out->{top} = ($h / 2 + 0.5) . 'em'; delete $out->{top} if $out->{top} eq '1.5em';
  8         14  
921 8         9 $h = ($h + 2) . 'em';
922 8         9 $w = ($w + 2) . 'em';
923              
924 8         11 $inner_style .= ";width: $w; height: $h";
925              
926 8         14 $inner_style = " style='$inner_style'";
927 8         15 $inner_start = "
";
928             }
929              
930 71 50       113 if ($class =~ /^group/)
931             {
932 0         0 delete $out->{border};
933 0         0 delete $out->{background};
934 0         0 my $group_class = $class; $group_class =~ s/\s.*//; # "group gt" => "group"
  0         0  
935 0         0 my @atr = qw/bordercolor borderwidth fill/;
936              
937             # transform "group_foo gr" to "group_foo" if border eq 'none' (for anon groups)
938 0         0 my $border_style = $self->attribute('borderstyle');
939 0 0       0 $c =~ s/\s+.*// if $border_style eq 'none';
940              
941             # only need the color for the label cell
942 0 0       0 push @atr, 'color' if $self->{has_label};
943 0 0       0 $name = ' ' unless $self->{has_label};
944 0         0 for my $b (@atr)
945             {
946 0         0 my $def = $g->attribute($group_class,$b);
947 0         0 my $v = $self->attribute($b);
948              
949 0 0       0 my $n = $b; $n = 'background' if $b eq 'fill';
  0         0  
950 0 0 0     0 $out->{$n} = $v unless $v eq '' || $v eq $def;
951             }
952 0 0       0 $name = ' ' unless $name ne '';
953             }
954              
955             # "shape: none;" or point means no border, and background instead fill color
956 71 50       160 if ($shape =~ /^(point|none)\z/)
957             {
958 0         0 $out->{background} = $self->color_attribute('background');
959 0         0 $out->{border} = 'none';
960             }
961              
962 71         62 my $style = '';
963 71         176 for my $atr (sort keys %$out)
964             {
965 35 100       62 if ($link ne '')
966             {
967             # put certain styles on the outer container, and not on the link
968 16 100       32 next if $atr =~ /^(background|border)\z/;
969             }
970 30         70 $style .= "$atr: $out->{$atr}; ";
971             }
972              
973             # bold, italic, underline etc. (but not for empty cells)
974 71 100       287 $style .= $self->text_styles_as_css(1,1) if $name !~ /^(| )\z/;
975              
976 71         133 $style =~ s/;\s?\z$//; # remove '; ' at end
977 71         116 $style =~ s/\s+/ /g; # ' ' => ' '
978 71         72 $style =~ s/^\s+//; # remove ' ' at front
979 71 100       115 $style = " style=\"$style\"" if $style;
980              
981 71         85 my $end_tag = "\n";
982              
983 71 100       119 if ($link ne '')
984             {
985             # encode critical entities
986 14         21 $link =~ s/\s/\+/g; # space
987 14         13 $link =~ s/'/%27/g; # replace quotation marks
988              
989 14         13 my $outer_style = '';
990             # put certain styles like border and background on the table cell:
991 14         18 for my $s (qw/background border/)
992             {
993 28 100       57 $outer_style .= "$s: $out->{$s};" if exists $out->{$s};
994             }
995 14         19 $outer_style =~ s/;\s?\z$//; # remove '; ' at end
996 14 100       25 $outer_style = ' style="'.$outer_style.'"' if $outer_style;
997              
998 14         14 $inner_start =~ s/##style##/$outer_style/; # remove from inner_start
999              
1000 14         29 $html =~ s/##style##/$outer_style/; # or HTML, depending
1001 14         18 $inner_start .= ""; # and put on link
1002 14         16 $inner_end = ''.$inner_end;
1003             }
1004              
1005 71 50       139 $c = " class='$c'" if $c ne '';
1006 71         111 $html .= ">$inner_start$name$inner_end$end_tag";
1007 71         177 $html =~ s/##class##/$c/;
1008 71         135 $html =~ s/##style##/$style/;
1009              
1010 71         123 $self->quoted_comment() . $html;
1011             }
1012              
1013             sub angle
1014             {
1015             # return the rotation of the node, dependend on the rotate attribute
1016             # (and if relative, on the flow)
1017 19     19 1 27 my $self = shift;
1018              
1019 19   100     35 my $angle = $self->{att}->{rotate} || 0;
1020              
1021 19 100       38 $angle = 180 if $angle =~ /^(south|down)\z/;
1022 19 50       26 $angle = 0 if $angle =~ /^(north|up)\z/;
1023 19 50       25 $angle = 270 if $angle eq 'west';
1024 19 50       26 $angle = 90 if $angle eq 'east';
1025              
1026             # convert relative angles
1027 19 100       38 if ($angle =~ /^([+-]\d+|left|right|back|front|forward)\z/)
1028             {
1029 12         24 my $base_rot = $self->flow();
1030 12 100       24 $angle = 0 if $angle =~ /^(front|forward)\z/;
1031 12 100       20 $angle = 180 if $angle eq 'back';
1032 12 100       18 $angle = -90 if $angle eq 'left';
1033 12 50       15 $angle = 90 if $angle eq 'right';
1034 12         14 $angle = $base_rot + $angle + 0; # 0 points up, so front points right
1035 12         21 $angle += 360 while $angle < 0;
1036             }
1037              
1038 19 50       52 $self->_croak("Illegal node angle $angle") if $angle !~ /^\d+\z/;
1039              
1040 19 100       26 $angle %= 360 if $angle > 359;
1041              
1042 19         68 $angle;
1043             }
1044              
1045             # for determining the absolute parent flow
1046             my $p_flow =
1047             {
1048             'east' => 90,
1049             'west' => 270,
1050             'north' => 0,
1051             'south' => 180,
1052             'up' => 0,
1053             'down' => 180,
1054             'back' => 270,
1055             'left' => 270,
1056             'right' => 90,
1057             'front' => 90,
1058             'forward' => 90,
1059             };
1060              
1061             sub _parent_flow_absolute
1062             {
1063             # make parent flow absolute
1064 1289     1289   1187 my ($self, $def) = @_;
1065              
1066 1289 50       2034 return '90' if ref($self) eq 'Graph::Easy';
1067              
1068 1289   100     1839 my $flow = $self->parent()->raw_attribute('flow') || $def;
1069              
1070 1289 100       2123 return unless defined $flow;
1071              
1072             # in case of relative flow at parent, convert to absolute (right: east, left: west etc)
1073             # so that "graph { flow: left; }" results in a westward flow
1074 640 100       787 my $f = $p_flow->{$flow}; $f = $flow unless defined $f;
  640         920  
1075 640         861 $f;
1076             }
1077              
1078             sub flow
1079             {
1080             # Calculate the outgoing flow from the incoming flow and the flow at this
1081             # node (either from edge(s) or general flow). Returns an absolute flow:
1082             # See the online manual about flow for a reference and details.
1083 4716     4716 1 3878 my $self = shift;
1084              
1085 48     48   250 no warnings 'recursion';
  48         56  
  48         166001  
1086              
1087 4716         4430 my $cache = $self->{cache};
1088 4716 100       9370 return $cache->{flow} if exists $cache->{flow};
1089              
1090             # detected cycle, so break it
1091 1053 100       1560 return $cache->{flow} = $self->_parent_flow_absolute('90') if exists $self->{_flow};
1092              
1093 1042         1578 local $self->{_flow} = undef; # endless loops really ruin our day
1094              
1095 1042         766 my $in;
1096 1042         1119 my $flow = $self->{att}->{flow};
1097              
1098 1042 100 66     2756 $flow = $self->_parent_flow_absolute() if !defined $flow || $flow eq 'inherit';
1099              
1100             # if flow is absolute, return it early
1101 1042 100 100     4231 return $cache->{flow} = $flow if defined $flow && $flow =~ /^(0|90|180|270)\z/;
1102 662 100 100     1164 return $cache->{flow} = Graph::Easy->_direction_as_number($flow)
1103             if defined $flow && $flow =~ /^(south|north|east|west|up|down)\z/;
1104              
1105             # for relative flows, compute the incoming flow as base flow
1106              
1107             # check all edges
1108 650         1284 for my $e (ord_values ( $self->{edges} ))
1109             {
1110             # only count incoming edges
1111 774 100 66     2329 next unless $e->{from} != $self && $e->{to} == $self;
1112              
1113             # if incoming edge has flow, we take this
1114 390         860 $in = $e->flow();
1115             # take the first match
1116 390 50       673 last if defined $in;
1117             }
1118              
1119 650 100       1136 if (!defined $in)
1120             {
1121             # check all predecessors
1122 260         533 for my $e (ord_values ( $self->{edges} ))
1123             {
1124 344         313 my $pre = $e->{from};
1125 344 100       518 $pre = $e->{to} if $e->{bidirectional};
1126 344 100       669 if ($pre != $self)
1127             {
1128 11         21 $in = $pre->flow();
1129             # take the first match
1130 11 50       28 last if defined $in;
1131             }
1132             }
1133             }
1134              
1135 650 100       1105 $in = $self->_parent_flow_absolute('90') unless defined $in;
1136              
1137 650 100       1882 $flow = Graph::Easy->_direction_as_number($in) unless defined $flow;
1138              
1139 650         1193 $cache->{flow} = Graph::Easy->_flow_as_direction($in,$flow);
1140             }
1141              
1142             #############################################################################
1143             # multi-celled nodes
1144              
1145             sub _calc_size
1146             {
1147             # Calculate the base size in cells from the attributes (before grow())
1148             # Will return a hash that denotes in which direction the node should grow.
1149 1158     1158   1072 my $self = shift;
1150              
1151             # If specified only one of "rows" or "columns", then grow the node
1152             # only in the unspecified direction. Default is grow both.
1153 1158         2057 my $grow_sides = { cx => 1, cy => 1 };
1154              
1155 1158         1249 my $r = $self->{att}->{rows};
1156 1158         963 my $c = $self->{att}->{columns};
1157 1158 100 100     2193 delete $grow_sides->{cy} if defined $r && !defined $c;
1158 1158 100 100     1867 delete $grow_sides->{cx} if defined $c && !defined $r;
1159              
1160 1158 100       2960 $r = $self->attribute('rows') unless defined $r;
1161 1158 100       2966 $c = $self->attribute('columns') unless defined $c;
1162              
1163 1158   50     2920 $self->{cy} = abs($r || 1);
1164 1158   50     2031 $self->{cx} = abs($c || 1);
1165              
1166 1158         1553 $grow_sides;
1167             }
1168              
1169             sub _grow
1170             {
1171             # Grows the node until it has sufficient cells for all incoming/outgoing
1172             # edges. The initial size will be based upon the attributes 'size' (or
1173             # 'rows' or 'columns', depending on which is set)
1174 1134     1134   1069 my $self = shift;
1175              
1176             # XXX TODO: grow the node based on its label dimensions
1177             # my ($w,$h) = $self->dimensions();
1178             #
1179             # my $cx = int(($w+2) / 5) || 1;
1180             # my $cy = int(($h) / 3) || 1;
1181             #
1182             # $self->{cx} = $cx if $cx > $self->{cx};
1183             # $self->{cy} = $cy if $cy > $self->{cy};
1184              
1185             # satisfy the edge start/end port constraints:
1186              
1187             # We calculate a bitmap (vector) for each side, and mark each
1188             # used port. Edges that have an unspecified port will just be
1189             # counted.
1190              
1191             # bitmap for each side:
1192 1134         2697 my $vec = { north => '', south => '', east => '', west => '' };
1193             # number of edges constrained to one side, but without port number
1194 1134         1881 my $cnt = { north => 0, south => 0, east => 0, west => 0 };
1195             # number of edges constrained to one side, with port number
1196 1134         1569 my $portnr = { north => 0, south => 0, east => 0, west => 0 };
1197             # max number of ports for each side
1198 1134         1633 my $max = { north => 0, south => 0, east => 0, west => 0 };
1199              
1200 1134         2209 my @idx = ( [ 'start', 'from' ], [ 'end', 'to' ] );
1201             # number of slots we need to edges without port restrictions
1202 1134         945 my $unspecified = 0;
1203              
1204             # count of outgoing edges
1205 1134         821 my $outgoing = 0;
1206              
1207 1134         2248 for my $e (ord_values ( $self->{edges} ))
1208             {
1209             # count outgoing edges
1210 1774 100       3238 $outgoing++ if $e->{from} == $self;
1211              
1212             # do always both ends, because self-loops can start AND end at this node:
1213 1774         2310 for my $end (0..1)
1214             {
1215             # if the edge starts/ends here
1216 3548 100       6713 if ($e->{$idx[$end]->[1]} == $self) # from/to
1217             {
1218 1805         3495 my ($side, $nr) = $e->port($idx[$end]->[0]); # start/end
1219              
1220 1805 100       2160 if (defined $side)
1221             {
1222 89 100 66     257 if (!defined $nr || $nr eq '')
1223             {
1224             # no port number specified, so just count
1225 41         77 $cnt->{$side}++;
1226             }
1227             else
1228             {
1229             # mark the bit in the vector
1230             # limit to four digits
1231 48 50       100 $nr = 9999 if abs($nr) > 9999;
1232              
1233             # if slot was not used yet, count it
1234 48 100       104 $portnr->{$side} ++ if vec($vec->{$side}, $nr, 1) == 0x0;
1235              
1236             # calculate max number of ports
1237 48 50       82 $nr = abs($nr) - 1 if $nr < 0; # 3 => 3, -3 => 2
1238 48         40 $nr++; # 3 => 4, -3 => 3
1239              
1240             # mark as used
1241 48         114 vec($vec->{$side}, $nr - 1, 1) = 0x01;
1242              
1243 48 100       153 $max->{$side} = $nr if $nr > $max->{$side};
1244             }
1245             }
1246             else
1247             {
1248 1716         2418 $unspecified ++;
1249             }
1250             } # end if port is constrained
1251             } # end for start/end port
1252             } # end for all edges
1253              
1254 1134         2590 for my $e (ord_values ( $self->{edges} ))
1255             {
1256             # the loop above will count all self-loops twice when they are
1257             # unrestricted. So subtract these again. Restricted self-loops
1258             # might start at one port and end at another, and this case is
1259             # covered correctly by the code above.
1260 1774 100       3310 $unspecified -- if $e->{to} == $e->{from};
1261             }
1262              
1263             # Shortcut, if the number of edges is < 4 and we have not restrictions,
1264             # then a 1x1 node suffices
1265 1134 100 100     2286 if ($unspecified < 4 && ($unspecified == keys %{$self->{edges}}))
  1090         3082  
1266             {
1267 1043         1769 $self->_calc_size();
1268 1043         4857 return $self;
1269             }
1270              
1271 91         106 my $need = {};
1272 91         96 my $free = {};
1273 91         113 for my $side (qw/north south east west/)
1274             {
1275             # maximum number of ports we need to reserve, minus edges constrained
1276             # to unique ports: free ports on that side
1277 364         483 $free->{$side} = $max->{$side} - $portnr->{$side};
1278 364         320 $need->{$side} = $max->{$side};
1279 364 100       594 if ($free->{$side} < 2 * $cnt->{$side})
1280             {
1281 31         65 $need->{$side} += 2 * $cnt->{$side} - $free->{$side} - 1;
1282             }
1283             }
1284             # now $need contains for each side the absolute min. number of ports we need
1285              
1286             # use Data::Dumper;
1287             # print STDERR "# port contraints for $self->{name}:\n";
1288             # print STDERR "# count: ", Dumper($cnt), "# max: ", Dumper($max),"\n";
1289             # print STDERR "# ports: ", Dumper($portnr),"\n";
1290             # print STDERR "# need : ", Dumper($need),"\n";
1291             # print STDERR "# free : ", Dumper($free),"\n";
1292              
1293             # calculate min. size in X and Y direction
1294 91 100       99 my $min_x = $need->{north}; $min_x = $need->{south} if $need->{south} > $min_x;
  91         173  
1295 91 100       89 my $min_y = $need->{west}; $min_y = $need->{east} if $need->{east} > $min_y;
  91         146  
1296              
1297 91         184 my $grow_sides = $self->_calc_size();
1298              
1299             # increase the size if the minimum required size is not met
1300 91 100       171 $self->{cx} = $min_x if $min_x > $self->{cx};
1301 91 100       145 $self->{cy} = $min_y if $min_y > $self->{cy};
1302              
1303 91         191 my $flow = $self->flow();
1304              
1305             # if this is a sink node, grow it more by ignoring free ports on the front side
1306 91         109 my $front_side = 'east';
1307 91 100       197 $front_side = 'west' if $flow == 270;
1308 91 100       148 $front_side = 'south' if $flow == 180;
1309 91 100       153 $front_side = 'north' if $flow == 0;
1310              
1311             # now grow the node based on the general flow first VER, then HOR
1312 91         70 my $grow = 0; # index into @grow_what
1313 91         332 my @grow_what = sort keys %$grow_sides; # 'cx', 'cy' or 'cx' or 'cy'
1314              
1315 91 100       246 if (keys %$grow_sides > 1)
1316             {
1317             # for left/right flow, swap the growing around
1318 89 100 100     291 @grow_what = ( 'cy', 'cx' ) if $flow == 90 || $flow == 270;
1319             }
1320              
1321             # fake a non-sink node for nodes with an offset/children
1322 91 100 100     252 $outgoing = 1 if ref($self->{origin}) || keys %{$self->{children}} > 0;
  69         301  
1323              
1324 91         89 while ( 3 < 5 )
1325             {
1326             # calculate whether we already found a space for all edges
1327 98         106 my $free_ports = 0;
1328 98         136 for my $side (qw/north south/)
1329             {
1330             # if this is a sink node, grow it more by ignoring free ports on the front side
1331 196 100 100     399 next if $outgoing == 0 && $front_side eq $side;
1332 195         468 $free_ports += 1 + int(($self->{cx} - $cnt->{$side} - $portnr->{$side}) / 2);
1333             }
1334 98         141 for my $side (qw/east west/)
1335             {
1336             # if this is a sink node, grow it more by ignoring free ports on the front side
1337 196 100 100     361 next if $outgoing == 0 && $front_side eq $side;
1338 187         326 $free_ports += 1 + int(($self->{cy} - $cnt->{$side} - $portnr->{$side}) / 2);
1339             }
1340 98 100       198 last if $free_ports >= $unspecified;
1341              
1342 7         14 $self->{ $grow_what[$grow] } += 2;
1343              
1344 7 50       7 $grow ++; $grow = 0 if $grow >= @grow_what;
  7         13  
1345             }
1346              
1347 91         615 $self;
1348             }
1349              
1350             sub is_multicelled
1351             {
1352             # return true if node consist of more than one cell
1353 1697     1697 1 1158 my $self = shift;
1354              
1355 1697 100       2274 $self->_calc_size() unless defined $self->{cx};
1356              
1357 1697         6277 $self->{cx} + $self->{cy} <=> 2; # 1 + 1 == 2: no, cx + xy != 2: yes
1358             }
1359              
1360             sub is_anon
1361             {
1362             # normal nodes are not anon nodes (but "::Anon" are)
1363 5     5 1 12 0;
1364             }
1365              
1366             #############################################################################
1367             # accessor methods
1368              
1369             sub _un_escape
1370             {
1371             # replace \N, \G, \T, \H and \E (depending on type)
1372             # if $label is false, also replace \L with the label
1373 27     27   30 my ($self, $txt, $do_label) = @_;
1374              
1375             # for edges:
1376 27 100       38 if (exists $self->{edge})
1377             {
1378 4         6 my $e = $self->{edge};
1379 4         22 $txt =~ s/\\E/$e->{from}->{name}\->$e->{to}->{name}/g;
1380 4         11 $txt =~ s/\\T/$e->{from}->{name}/g;
1381 4         10 $txt =~ s/\\H/$e->{to}->{name}/g;
1382             # \N for edges is the label of the edge
1383 4 50       11 if ($txt =~ /\\N/)
1384             {
1385 0         0 my $l = $self->label();
1386 0         0 $txt =~ s/\\N/$l/g;
1387             }
1388             }
1389             else
1390             {
1391             # \N for nodes
1392 23         53 $txt =~ s/\\N/$self->{name}/g;
1393             }
1394             # \L with the label
1395 27 100 66     57 if ($txt =~ /\\L/ && $do_label)
1396             {
1397 2         4 my $l = $self->label();
1398 2         6 $txt =~ s/\\L/$l/g;
1399             }
1400              
1401             # \G for edges and nodes
1402 27 100       43 if ($txt =~ /\\G/)
1403             {
1404 21         18 my $g = '';
1405             # the graph itself
1406 21 100       46 $g = $self->attribute('title') unless ref($self->{graph});
1407             # any nodes/edges/groups in it
1408 21 100       55 $g = $self->{graph}->label() if ref($self->{graph});
1409 21         43 $txt =~ s/\\G/$g/g;
1410             }
1411 27         41 $txt;
1412             }
1413              
1414             sub title
1415             {
1416             # Returns a title of the node (or '', if none was set), which can be
1417             # used for mouse-over titles
1418              
1419 110     110 1 94 my $self = shift;
1420              
1421 110         191 my $title = $self->attribute('title');
1422 110 100       194 if ($title eq '')
1423             {
1424 99         183 my $autotitle = $self->attribute('autotitle');
1425 99 50       154 if (defined $autotitle)
1426             {
1427 99         79 $title = ''; # default is none
1428              
1429 99 100       157 if ($autotitle eq 'name') # use name
1430             {
1431 15         17 $title = $self->{name};
1432             # edges do not have a name and fall back on their label
1433 15 100       32 $title = $self->{att}->{label} unless defined $title;
1434             }
1435              
1436 99 100       142 if ($autotitle eq 'label')
1437             {
1438 2         3 $title = $self->{name}; # fallback to name
1439             # defined to avoid overriding "name" with the non-existent label attribute
1440             # do not use label() here, but the "raw" label of the edge:
1441 2 50       5 my $label = $self->label(); $title = $label if defined $label;
  2         6  
1442             }
1443              
1444 99 100       135 $title = $self->link() if $autotitle eq 'link';
1445             }
1446 99 100       149 $title = '' unless defined $title;
1447             }
1448              
1449 110 100 66     365 $title = $self->_un_escape($title, 1) if !$_[0] && $title =~ /\\[EGHNTL]/;
1450              
1451 110         160 $title;
1452             }
1453              
1454             sub background
1455             {
1456             # get the background for this group/edge cell, honouring group membership.
1457 4     4 1 12 my $self = shift;
1458              
1459 4         11 $self->color_attribute('background');
1460             }
1461              
1462             sub label
1463             {
1464 5819     5819 1 6318 my $self = shift;
1465              
1466             # shortcut to speed it up a bit:
1467 5819         5536 my $label = $self->{att}->{label};
1468 5819 100       12008 $label = $self->attribute('label') unless defined $label;
1469              
1470             # for autosplit nodes, use their auto-label first (unless already got
1471             # a label from the class):
1472 5819 100       10436 $label = $self->{autosplit_label} unless defined $label;
1473 5819 100       8186 $label = $self->{name} unless defined $label;
1474              
1475 5819 100       8646 return '' unless defined $label;
1476              
1477 3949 100       5319 if ($label ne '')
1478             {
1479 3634         5664 my $len = $self->attribute('autolabel');
1480 3634 100       5580 if ($len ne '')
1481             {
1482             # allow the old format (pre v0.49), too: "name,12" => 12
1483 8         31 $len =~ s/^name\s*,\s*//;
1484             # restrict to sane values
1485 8 50 50     22 $len = abs($len || 0); $len = 99999 if $len > 99999;
  8         15  
1486 8 100       18 if (length($label) > $len)
1487             {
1488 6   50     12 my $g = $self->{graph} || {};
1489 6 50 50     23 if ((($g->{_ascii_style}) || 0) == 0)
1490             {
1491             # ASCII output
1492 6 50       9 $len = int($len / 2) - 3; $len = 0 if $len < 0;
  6         8  
1493 6         20 $label = substr($label, 0, $len) . ' ... ' . substr($label, -$len, $len);
1494             }
1495             else
1496             {
1497 0 0       0 $len = int($len / 2) - 2; $len = 0 if $len < 0;
  0         0  
1498 0         0 $label = substr($label, 0, $len) . ' … ' . substr($label, -$len, $len);
1499             }
1500             }
1501             }
1502             }
1503              
1504 3949 100 100     11615 $label = $self->_un_escape($label) if !$_[0] && $label =~ /\\[EGHNT]/;
1505              
1506 3949         5946 $label;
1507             }
1508              
1509             sub name
1510             {
1511 1600     1600 1 2471 my $self = shift;
1512              
1513 1600         2064 $self->{name};
1514             }
1515              
1516             sub x
1517             {
1518 4     4 1 8 my $self = shift;
1519              
1520 4         13 $self->{x};
1521             }
1522              
1523             sub y
1524             {
1525 4     4 1 5 my $self = shift;
1526              
1527 4         43 $self->{y};
1528             }
1529              
1530             sub width
1531             {
1532 7     7 1 9 my $self = shift;
1533              
1534 7         22 $self->{w};
1535             }
1536              
1537             sub height
1538             {
1539 6     6 1 8 my $self = shift;
1540              
1541 6         22 $self->{h};
1542             }
1543              
1544             sub origin
1545             {
1546             # Returns node that this node is relative to or undef, if not.
1547 5     5 1 1015 my $self = shift;
1548              
1549 5         16 $self->{origin};
1550             }
1551              
1552             sub pos
1553             {
1554 4     4 1 5 my $self = shift;
1555              
1556 4   50     50 ($self->{x} || 0, $self->{y} || 0);
      50        
1557             }
1558              
1559             sub offset
1560             {
1561 73     73 1 98 my $self = shift;
1562              
1563 73   100     510 ($self->{dx} || 0, $self->{dy} || 0);
      100        
1564             }
1565              
1566             sub columns
1567             {
1568 2     2 1 5 my $self = shift;
1569              
1570 2 50       6 $self->_calc_size() unless defined $self->{cx};
1571              
1572 2         6 $self->{cx};
1573             }
1574              
1575             sub rows
1576             {
1577 2     2 1 3 my $self = shift;
1578              
1579 2 50       8 $self->_calc_size() unless defined $self->{cy};
1580              
1581 2         4 $self->{cy};
1582             }
1583              
1584             sub size
1585             {
1586 27     27 1 30 my $self = shift;
1587              
1588 27 100       61 $self->_calc_size() unless defined $self->{cx};
1589              
1590 27         114 ($self->{cx}, $self->{cy});
1591             }
1592              
1593             sub shape
1594             {
1595 57     57 1 47 my $self = shift;
1596              
1597 57         35 my $shape;
1598 57 100       95 $shape = $self->{att}->{shape} if exists $self->{att}->{shape};
1599 57 100       125 $shape = $self->attribute('shape') unless defined $shape;
1600 57         155 $shape;
1601             }
1602              
1603             sub dimensions
1604             {
1605             # Returns the minimum dimensions of the node/cell derived from the
1606             # label or name, in characters.
1607 1908     1908 1 1629 my $self = shift;
1608              
1609 1908         3124 my $align = $self->attribute('align');
1610 1908         3389 my ($lines,$aligns) = $self->_aligned_label($align);
1611              
1612 1908         1770 my $w = 0; my $h = scalar @$lines;
  1908         1580  
1613 1908         2312 foreach my $line (@$lines)
1614             {
1615 1201 100       2782 $w = length($line) if length($line) > $w;
1616             }
1617 1908         3775 ($w,$h);
1618             }
1619              
1620             #############################################################################
1621             # edges and connections
1622              
1623             sub edges_to
1624             {
1625             # Return all the edge objects that start at this vertex and go to $other.
1626 1236     1236 1 1159 my ($self, $other) = @_;
1627              
1628             # no graph, no dice
1629 1236 100       2071 return unless ref $self->{graph};
1630              
1631 1235         900 my @edges;
1632 1235         1853 for my $edge (ord_values ( $self->{edges} ))
1633             {
1634 2511 100 100     7920 push @edges, $edge if $edge->{from} == $self && $edge->{to} == $other;
1635             }
1636 1235         2801 @edges;
1637             }
1638              
1639             sub edges_at_port
1640             {
1641             # return all edges that share the same given port
1642 81     81 1 97 my ($self, $attr, $side, $port) = @_;
1643              
1644             # Must be "start" or "end"
1645 81 50       257 return () unless $attr =~ /^(start|end)\z/;
1646              
1647 81 50       115 $self->_croak('side not defined') unless defined $side;
1648 81 50       107 $self->_croak('port not defined') unless defined $port;
1649              
1650 81         62 my @edges;
1651 81         179 for my $e (ord_values ( $self->{edges} ))
1652             {
1653             # skip edges ending here if we look at start
1654 292 100 100     861 next if $e->{to} eq $self && $attr eq 'start';
1655             # skip edges starting here if we look at end
1656 275 100 100     648 next if $e->{from} eq $self && $attr eq 'end';
1657              
1658 263         444 my ($s_p,@ss_p) = $e->port($attr);
1659 263 50       417 next unless defined $s_p;
1660              
1661             # same side and same port number?
1662 263 50 66     1375 push @edges, $e
      66        
1663             if $s_p eq $side && @ss_p == 1 && $ss_p[0] eq $port;
1664             }
1665              
1666 81         222 @edges;
1667             }
1668              
1669             sub shared_edges
1670             {
1671             # return all edges that share one port with another edge
1672 0     0 1 0 my ($self) = @_;
1673              
1674 0         0 my @edges;
1675 0         0 for my $e (ord_values ( $self->{edges} ))
1676             {
1677 0         0 my ($s_p,@ss_p) = $e->port('start');
1678 0 0       0 push @edges, $e if defined $s_p;
1679 0         0 my ($e_p,@ee_p) = $e->port('end');
1680 0 0       0 push @edges, $e if defined $e_p;
1681             }
1682 0         0 @edges;
1683             }
1684              
1685             sub nodes_sharing_start
1686             {
1687             # return all nodes that share an edge start with an
1688             # edge from that node
1689 15     15 1 25 my ($self, $side, @port) = @_;
1690              
1691 15         34 my @edges = $self->edges_at_port('start',$side,@port);
1692              
1693 15         15 my $nodes;
1694 15         18 for my $e (@edges)
1695             {
1696             # ignore self-loops
1697 45         40 my $to = $e->{to};
1698 45 50       60 next if $to == $self;
1699              
1700             # remove duplicates
1701 45         80 $nodes->{ $to->{name} } = $to;
1702             }
1703              
1704 15         32 return (ord_values $nodes);
1705             }
1706              
1707             sub nodes_sharing_end
1708             {
1709             # return all nodes that share an edge end with an
1710             # edge from that node
1711 18     18 1 29 my ($self, $side, @port) = @_;
1712              
1713 18         33 my @edges = $self->edges_at_port('end',$side,@port);
1714              
1715 18         16 my $nodes;
1716 18         27 for my $e (@edges)
1717             {
1718             # ignore self-loops
1719 58         47 my $from = $e->{from};
1720 58 50       73 next if $from == $self;
1721              
1722             # remove duplicates
1723 58         133 $nodes->{ $from->{name} } = $from;
1724             }
1725              
1726 18         41 return (ord_values $nodes);
1727             }
1728              
1729             sub incoming
1730             {
1731             # return all edges that end at this node
1732 7     7 1 13 my $self = shift;
1733              
1734             # no graph, no dice
1735 7 100       15 return unless ref $self->{graph};
1736              
1737 6 50       11 if (!wantarray)
1738             {
1739 6         3 my $count = 0;
1740 6         12 for my $edge (ord_values ( $self->{edges} ))
1741             {
1742 10 100       19 $count++ if $edge->{to} == $self;
1743             }
1744 6         21 return $count;
1745             }
1746              
1747 0         0 my @edges;
1748 0         0 for my $edge (ord_values ( $self->{edges} ))
1749             {
1750 0 0       0 push @edges, $edge if $edge->{to} == $self;
1751             }
1752 0         0 @edges;
1753             }
1754              
1755             sub outgoing
1756             {
1757             # return all edges that start at this node
1758 7     7 1 11 my $self = shift;
1759              
1760             # no graph, no dice
1761 7 100       18 return unless ref $self->{graph};
1762              
1763 6 50       10 if (!wantarray)
1764             {
1765 6         7 my $count = 0;
1766 6         13 for my $edge (ord_values ( $self->{edges} ))
1767             {
1768 10 100       19 $count++ if $edge->{from} == $self;
1769             }
1770 6         19 return $count;
1771             }
1772              
1773 0         0 my @edges;
1774 0         0 for my $edge (ord_values ( $self->{edges} ))
1775             {
1776 0 0       0 push @edges, $edge if $edge->{from} == $self;
1777             }
1778 0         0 @edges;
1779             }
1780              
1781             sub connections
1782             {
1783             # return number of connections (incoming+outgoing)
1784 18     18 1 37 my $self = shift;
1785              
1786 18 100       43 return 0 unless defined $self->{graph};
1787              
1788             # We need to count the connections, because "[A]->[A]" creates
1789             # two connections on "A", but only one edge!
1790 15         13 my $con = 0;
1791 15         30 for my $edge (ord_values ( $self->{edges} ))
1792             {
1793 31 100       43 $con ++ if $edge->{to} == $self;
1794 31 100       57 $con ++ if $edge->{from} == $self;
1795             }
1796 15         47 $con;
1797             }
1798              
1799             sub edges
1800             {
1801             # return all the edges
1802 5     5 1 456 my $self = shift;
1803              
1804             # no graph, no dice
1805 5 100       14 return unless ref $self->{graph};
1806              
1807             return (wantarray
1808             ? ord_values ( $self->{edges} )
1809 4 100       13 : scalar keys %{$self->{edges}}
  1         4  
1810             );
1811             }
1812              
1813             sub sorted_successors
1814             {
1815             # return successors of the node sorted by their chain value
1816             # (e.g. successors with more successors first)
1817 887     887 1 795 my $self = shift;
1818              
1819             my @suc = sort {
1820 887         1231 scalar $b->successors() <=> scalar $a->successors() ||
1821             scalar $a->{name} cmp scalar $b->{name}
1822 160 50       265 } $self->successors();
1823 887         1933 @suc;
1824             }
1825              
1826             sub successors
1827             {
1828             # return all nodes (as objects) we are linked to
1829 3637     3637 1 4595 my $self = shift;
1830              
1831 3637 100       5565 return () unless defined $self->{graph};
1832              
1833 3633         2559 my %suc;
1834 3633         5674 for my $edge (ord_values ( $self->{edges} ))
1835             {
1836 5156 100       8664 next unless $edge->{from} == $self;
1837 2546         4436 $suc{$edge->{to}->{id}} = $edge->{to}; # weed out doubles
1838             }
1839 3633         6205 return ord_values( \%suc );
1840             }
1841              
1842             sub predecessors
1843             {
1844             # return all nodes (as objects) that link to us
1845 2684     2684 1 2140 my $self = shift;
1846              
1847 2684 100       3801 return () unless defined $self->{graph};
1848              
1849 2681         1818 my %pre;
1850 2681         4168 for my $edge (ord_values ( $self->{edges} ))
1851             {
1852 3583 100       6089 next unless $edge->{to} == $self;
1853 1998         3892 $pre{$edge->{from}->{id}} = $edge->{from}; # weed out doubles
1854             }
1855 2681         4820 return ord_values(\%pre);
1856             }
1857              
1858             sub has_predecessors
1859             {
1860             # return true if node has incoming edges (even from itself)
1861 1175     1175 1 845 my $self = shift;
1862              
1863 1175 50       1600 return undef unless defined $self->{graph};
1864              
1865 1175         1590 for my $edge (ord_values ( $self->{edges} ))
1866             {
1867 1259 100       3858 return 1 if $edge->{to} == $self; # found one
1868             }
1869 485         1426 0; # found none
1870             }
1871              
1872             sub has_as_predecessor
1873             {
1874             # return true if other is a predecessor of node
1875 8     8 1 10 my ($self,$other) = @_;
1876              
1877 8 50       19 return () unless defined $self->{graph};
1878              
1879 8         17 for my $edge (ord_values ( $self->{edges} ))
1880             {
1881             return 1 if
1882 10 100 100     44 $edge->{to} == $self && $edge->{from} == $other; # found one
1883             }
1884 5         16 0; # found none
1885             }
1886              
1887             sub has_as_successor
1888             {
1889             # return true if other is a successor of node
1890 7     7 1 15 my ($self,$other) = @_;
1891              
1892 7 50       17 return () unless defined $self->{graph};
1893              
1894 7         14 for my $edge (ord_values ( $self->{edges} ))
1895             {
1896             return 1 if
1897 8 100 100     38 $edge->{from} == $self && $edge->{to} == $other; # found one
1898              
1899             }
1900 5         15 0; # found none
1901             }
1902              
1903             #############################################################################
1904             # relatively placed nodes
1905              
1906             sub relative_to
1907             {
1908             # Sets the new origin if passed a Graph::Easy::Node object.
1909 198     198 1 217 my ($self,$parent,$dx,$dy) = @_;
1910              
1911 198 50 33     809 if (!ref($parent) || !$parent->isa('Graph::Easy::Node'))
1912             {
1913 0         0 require Carp;
1914 0         0 Carp::confess("Can't set origin to non-node object $parent");
1915             }
1916              
1917 198         311 my $grandpa = $parent->find_grandparent();
1918 198 50       406 if ($grandpa == $self)
1919             {
1920 0         0 require Carp;
1921 0         0 Carp::confess( "Detected loop in origin-chain:"
1922             ." tried to set origin of '$self->{name}' to my own grandchild $parent->{name}");
1923             }
1924              
1925             # unregister us with our old parent
1926 198 100       319 delete $self->{origin}->{children}->{$self->{id}} if defined $self->{origin};
1927              
1928 198         245 $self->{origin} = $parent;
1929 198 100       334 $self->{dx} = $dx if defined $dx;
1930 198 100       298 $self->{dy} = $dy if defined $dy;
1931 198 100       307 $self->{dx} = 0 unless defined $self->{dx};
1932 198 100       328 $self->{dy} = 0 unless defined $self->{dy};
1933              
1934             # register us as a new child
1935 198         376 $parent->{children}->{$self->{id}} = $self;
1936              
1937 198         280 $self;
1938             }
1939              
1940             sub find_grandparent
1941             {
1942             # For a node that has no origin (is not relative to another), returns
1943             # $self. For all others, follows the chain of origin back until we
1944             # hit a node without a parent. This code assumes there are no loops,
1945             # which origin() prevents from happening.
1946 2848     2848 1 2040 my $cur = shift;
1947              
1948 2848 100       3687 if (wantarray)
1949             {
1950 18         16 my $ox = 0;
1951 18         19 my $oy = 0;
1952 18         35 while (defined($cur->{origin}))
1953             {
1954 34         34 $ox -= $cur->{dx};
1955 34         25 $oy -= $cur->{dy};
1956 34         49 $cur = $cur->{origin};
1957             }
1958 18         31 return ($cur,$ox,$oy);
1959             }
1960              
1961 2830         4194 while (defined($cur->{origin}))
1962             {
1963 328         489 $cur = $cur->{origin};
1964             }
1965              
1966 2830         4172 $cur;
1967             }
1968              
1969             #############################################################################
1970             # attributes
1971              
1972             sub del_attribute
1973             {
1974 77     77 1 2940 my ($self, $name) = @_;
1975              
1976             # font-size => fontsize
1977 77 100       136 $name = $att_aliases->{$name} if exists $att_aliases->{$name};
1978              
1979 77         83 $self->{cache} = {};
1980              
1981 77         95 my $a = $self->{att};
1982 77         74 delete $a->{$name};
1983 77 100       114 if ($name eq 'size')
1984             {
1985 1         1 delete $a->{rows};
1986 1         2 delete $a->{columns};
1987             }
1988 77 50       106 if ($name eq 'border')
1989             {
1990 0         0 delete $a->{borderstyle};
1991 0         0 delete $a->{borderwidth};
1992 0         0 delete $a->{bordercolor};
1993             }
1994 77         98 $self;
1995             }
1996              
1997             sub set_attribute
1998             {
1999 965     965 1 32560 my ($self, $name, $v, $class) = @_;
2000              
2001 965         1327 $self->{cache} = {};
2002              
2003 965 50       1630 $name = 'undef' unless defined $name;
2004 965 50       1261 $v = 'undef' unless defined $v;
2005              
2006             # font-size => fontsize
2007 965 100       1536 $name = $att_aliases->{$name} if exists $att_aliases->{$name};
2008              
2009             # edge.cities => edge
2010 965 100       2618 $class = $self->main_class() unless defined $class;
2011              
2012             # remove quotation marks, but not for titles, labels etc
2013 965         2290 my $val = Graph::Easy->unquote_attribute($class,$name,$v);
2014              
2015 965         993 my $g = $self->{graph};
2016              
2017 965 100       1668 $g->{score} = undef if $g; # invalidate layout to force a new layout
2018              
2019 965 100       761 my $strict = 0; $strict = $g->{strict} if $g;
  965         1402  
2020 965 100       1281 if ($strict)
2021             {
2022 186         382 my ($rc, $newname, $v) = $g->validate_attribute($name,$val,$class);
2023              
2024 186 100       306 return if defined $rc; # error?
2025              
2026 185         219 $val = $v;
2027             }
2028              
2029 964 100       2334 if ($name eq 'class')
    100          
    100          
2030             {
2031 15         61 $self->sub_class($val);
2032 15         22 return $val;
2033             }
2034             elsif ($name eq 'group')
2035             {
2036 2         11 $self->add_to_group($val);
2037 2         4 return $val;
2038             }
2039             elsif ($name eq 'border')
2040             {
2041 31         36 my $c = $self->{att};
2042              
2043 31         79 ($c->{borderstyle}, $c->{borderwidth}, $c->{bordercolor}) =
2044             $g->split_border_attributes( $val );
2045              
2046 31         68 return $val;
2047             }
2048              
2049 916 100       2000 if ($name =~ /^(columns|rows|size)\z/)
2050             {
2051 24 100       46 if ($name eq 'size')
2052             {
2053 16         52 $val =~ /^(\d+)\s*,\s*(\d+)\z/;
2054 16         53 my ($cx, $cy) = (abs(int($1)),abs(int($2)));
2055 16         49 ($self->{att}->{columns}, $self->{att}->{rows}) = ($cx, $cy);
2056             }
2057             else
2058             {
2059 8         15 $self->{att}->{$name} = abs(int($val));
2060             }
2061 24         46 return $self;
2062             }
2063              
2064 892 100       1447 if ($name =~ /^(origin|offset)\z/)
2065             {
2066             # Only the first autosplit node get the offset/origin
2067 151 100 100     355 return $self if exists $self->{autosplit} && !defined $self->{autosplit};
2068              
2069 143 100       237 if ($name eq 'origin')
2070             {
2071             # if it doesn't exist, add it
2072 73         195 my $org = $self->{graph}->add_node($val);
2073 73         164 $self->relative_to($org);
2074              
2075             # set the attributes, too, so get_attribute('origin') works, too:
2076 73         105 $self->{att}->{origin} = $org->{name};
2077             }
2078             else
2079             {
2080             # offset
2081             # if it doesn't exist, add it
2082 70         297 my ($x,$y) = split/\s*,\s*/, $val;
2083 70         116 $x = int($x);
2084 70         80 $y = int($y);
2085 70 50 66     187 if ($x == 0 && $y == 0)
2086             {
2087 0         0 $g->error("Error in attribute: 'offset' is 0,0 in node $self->{name} with class '$class'");
2088 0         0 return;
2089             }
2090 70         124 $self->{dx} = $x;
2091 70         124 $self->{dy} = $y;
2092              
2093             # set the attributes, too, so get_attribute('origin') works, too:
2094 70         199 $self->{att}->{offset} = "$self->{dx},$self->{dy}";
2095             }
2096 143         254 return $self;
2097             }
2098              
2099 741         1630 $self->{att}->{$name} = $val;
2100             }
2101              
2102             sub set_attributes
2103             {
2104 3888     3888 1 4498 my ($self, $atr, $index) = @_;
2105              
2106 3888         6309 foreach my $n (sort keys %$atr)
2107             {
2108 769         915 my $val = $atr->{$n};
2109 769 100 66     1491 $val = $val->[$index] if ref($val) eq 'ARRAY' && defined $index;
2110              
2111 769 100 66     2761 next if !defined $val || $val eq '';
2112              
2113 762 100       1655 $n eq 'class' ? $self->sub_class($val) : $self->set_attribute($n, $val);
2114             }
2115 3888         5152 $self;
2116             }
2117              
2118             BEGIN
2119             {
2120             # some handy aliases
2121 48     48   175 *text_styles_as_css = \&Graph::Easy::text_styles_as_css;
2122 48         141 *text_styles = \&Graph::Easy::text_styles;
2123 48         84 *_font_size_in_pixels = \&Graph::Easy::_font_size_in_pixels;
2124 48         151 *get_color_attribute = \&color_attribute;
2125 48         90 *link = \&Graph::Easy::link;
2126 48         63 *border_attribute = \&Graph::Easy::border_attribute;
2127 48         65 *get_attributes = \&Graph::Easy::get_attributes;
2128 48         66 *get_attribute = \&Graph::Easy::attribute;
2129 48         59 *raw_attribute = \&Graph::Easy::raw_attribute;
2130 48         84 *get_raw_attribute = \&Graph::Easy::raw_attribute;
2131 48         65 *raw_color_attribute = \&Graph::Easy::raw_color_attribute;
2132 48         57 *raw_attributes = \&Graph::Easy::raw_attributes;
2133 48         51 *raw_attributes = \&Graph::Easy::raw_attributes;
2134 48         55 *attribute = \&Graph::Easy::attribute;
2135 48         87 *color_attribute = \&Graph::Easy::color_attribute;
2136 48         61 *default_attribute = \&Graph::Easy::default_attribute;
2137 48         145 $att_aliases = Graph::Easy::_att_aliases();
2138             }
2139              
2140             #############################################################################
2141              
2142             sub group
2143             {
2144             # return the group this object belongs to
2145 4507     4507 1 3452 my $self = shift;
2146              
2147 4507         5254 $self->{group};
2148             }
2149              
2150             sub add_to_group
2151             {
2152 115     115 1 129 my ($self,$group) = @_;
2153              
2154 115         106 my $graph = $self->{graph}; # shortcut
2155              
2156             # delete from old group if nec.
2157 115 100       181 $self->{group}->del_member($self) if ref $self->{group};
2158              
2159             # if passed a group name, create or find group object
2160 115 100 66     294 $group = $graph->add_group($group) if (!ref($group) && $graph);
2161              
2162             # To make attribute('group') work:
2163 115         168 $self->{att}->{group} = $group->{name};
2164              
2165 115         287 $group->add_member($self);
2166              
2167 115         143 $self;
2168             }
2169              
2170             sub parent
2171             {
2172             # return parent object, either the group the node belongs to, or the graph
2173 2669     2669 1 2035 my $self = shift;
2174              
2175 2669         2226 my $p = $self->{graph};
2176              
2177 2669 100       3572 $p = $self->{group} if ref($self->{group});
2178              
2179 2669         5254 $p;
2180             }
2181              
2182             sub _update_boundaries
2183             {
2184 4216     4216   3387 my ($self, $parent) = @_;
2185              
2186             # XXX TODO: use current layout parent for recursive layouter:
2187 4216         3506 $parent = $self->{graph};
2188              
2189             # cache max boundaries for A* algorithmn:
2190              
2191 4216         3457 my $x = $self->{x};
2192 4216         3269 my $y = $self->{y};
2193              
2194             # create the cache if it doesn't already exist
2195 4216 100       6510 $parent->{cache} = {} unless ref($parent->{cache});
2196              
2197 4216         3097 my $cache = $parent->{cache};
2198              
2199 4216 100 100     12842 $cache->{min_x} = $x if !defined $cache->{min_x} || $x < $cache->{min_x};
2200 4216 100 100     11786 $cache->{min_y} = $y if !defined $cache->{min_y} || $y < $cache->{min_y};
2201              
2202 4216   100     9698 $x = $x + ($self->{cx}||1) - 1;
2203 4216   100     7885 $y = $y + ($self->{cy}||1) - 1;
2204 4216 100 100     11975 $cache->{max_x} = $x if !defined $cache->{max_x} || $x > $cache->{max_x};
2205 4216 100 100     11230 $cache->{max_y} = $y if !defined $cache->{max_y} || $y > $cache->{max_y};
2206              
2207 4216 50 50     11557 if (($parent->{debug}||0) > 1)
2208             {
2209 0 0       0 my $n = $self->{name}; $n = $self unless defined $n;
  0         0  
2210 0         0 print STDERR "Update boundaries for $n (parent $parent) at $x, $y\n";
2211              
2212 0         0 print STDERR "Boundaries are now: " .
2213             "$cache->{min_x},$cache->{min_y} => $cache->{max_x},$cache->{max_y}\n";
2214             }
2215              
2216 4216         4987 $self;
2217             }
2218              
2219             1;
2220             __END__