File Coverage

lib/Graph/Easy.pm
Criterion Covered Total %
statement 799 951 84.0
branch 360 518 69.5
condition 120 203 59.1
subroutine 91 114 79.8
pod 78 78 100.0
total 1448 1864 77.6


line stmt bran cond sub pod time code
1             ############################################################################
2             # Manage, and layout graphs on a flat plane.
3             #
4             #############################################################################
5              
6             package Graph::Easy;
7              
8 48     48   377988 use 5.008002;
  48         122  
9 48     48   6933 use Graph::Easy::Base;
  48         61  
  48         978  
10 48     48   7151 use Graph::Easy::Attributes;
  48         356  
  48         2349  
11 48     48   12527 use Graph::Easy::Edge;
  48         69  
  48         1033  
12 48     48   10421 use Graph::Easy::Group;
  48         76  
  48         1218  
13 48     48   10376 use Graph::Easy::Group::Anon;
  48         66  
  48         1052  
14 48     48   9342 use Graph::Easy::Layout;
  48         90  
  48         1407  
15 48     48   216 use Graph::Easy::Node;
  48         54  
  48         761  
16 48     48   10187 use Graph::Easy::Node::Anon;
  48         76  
  48         1154  
17 48     48   9971 use Graph::Easy::Node::Empty;
  48         75  
  48         1184  
18 48     48   184 use Scalar::Util qw/weaken/;
  48         52  
  48         2599  
19              
20             $VERSION = '0.76';
21             @ISA = qw/Graph::Easy::Base/;
22              
23 48     48   194 use strict;
  48         63  
  48         763  
24 48     48   193 use warnings;
  48         49  
  48         1212  
25             my $att_aliases;
26              
27 48     48   156 use Graph::Easy::Util qw(ord_values);
  48         55  
  48         9324  
28              
29             BEGIN
30             {
31             # a few aliases for backwards compatibility
32 48     48   146 *get_attribute = \&attribute;
33 48         158 *as_html_page = \&as_html_file;
34 48         172 *as_graphviz_file = \&as_graphviz;
35 48         101 *as_ascii_file = \&as_ascii;
36 48         101 *as_boxart_file = \&as_boxart;
37 48         106 *as_txt_file = \&as_txt;
38 48         117 *as_vcg_file = \&as_vcg;
39 48         97 *as_gdl_file = \&as_gdl;
40 48         115 *as_graphml_file = \&as_graphml;
41              
42             # a few aliases for code re-use
43 48         78 *_aligned_label = \&Graph::Easy::Node::_aligned_label;
44 48         87 *quoted_comment = \&Graph::Easy::Node::quoted_comment;
45 48         77 *_un_escape = \&Graph::Easy::Node::_un_escape;
46 48         87 *_convert_pod = \&Graph::Easy::Node::_convert_pod;
47 48         90 *_label_as_html = \&Graph::Easy::Node::_label_as_html;
48 48         91 *_wrapped_label = \&Graph::Easy::Node::_wrapped_label;
49 48         154 *get_color_attribute = \&color_attribute;
50 48         86 *get_custom_attributes = \&Graph::Easy::Node::get_custom_attributes;
51 48         73 *custom_attributes = \&Graph::Easy::Node::get_custom_attributes;
52 48         158 $att_aliases = Graph::Easy::_att_aliases();
53              
54             # backwards compatibility
55 48         137 *is_simple_graph = \&is_simple;
56              
57             # compatibility to Graph
58 48         137873 *vertices = \&nodes;
59             }
60              
61             #############################################################################
62              
63             sub new
64             {
65             # override new() as to not set the {id}
66 912     912 1 36396 my $class = shift;
67              
68             # called like "new->('[A]->[B]')":
69 912 100 100     3988 if (@_ == 1 && !ref($_[0]))
70             {
71 3         588 require Graph::Easy::Parser;
72 3         24 my $parser = Graph::Easy::Parser->new();
73 3         5 my $self = eval { $parser->from_text($_[0]); };
  3         9  
74 3 50       9 if (!defined $self)
75             {
76 0         0 $self = Graph::Easy->new( fatal_errors => 0 );
77 0   0     0 $self->error( 'Error: ' . $parser->error() ||
78             'Unknown error while parsing initial text' );
79 0         0 $self->catch_errors( 0 );
80             }
81 3         125 return $self;
82             }
83              
84 909         1218 my $self = bless {}, $class;
85              
86 909         877 my $args = $_[0];
87 909 100       1745 $args = { @_ } if ref($args) ne 'HASH';
88              
89 909         1675 $self->_init($args);
90             }
91              
92             sub DESTROY
93             {
94 934     934   17020 my $self = shift;
95              
96             # Be careful to not delete ->{graph}, these will be cleaned out by
97             # Perl automatically in O(1) time, manual delete is O(N) instead.
98              
99 934         1055 delete $self->{chains};
100             # clean out pointers in child-objects so that they can safely be reused
101 934         2122 for my $n (ord_values ( $self->{nodes} ))
102             {
103 1511 50       2552 if (ref($n))
104             {
105 1511         3758 delete $n->{edges};
106 1511         1557 delete $n->{group};
107             }
108             }
109 934         1882 for my $e (ord_values ( $self->{edges} ))
110             {
111 1065 50       1655 if (ref($e))
112             {
113 1065         1385 delete $e->{cells};
114 1065         927 delete $e->{to};
115 1065         1109 delete $e->{from};
116             }
117             }
118 934         1586 for my $g (ord_values ( $self->{groups} ))
119             {
120 62 50       112 if (ref($g))
121             {
122 62         88 delete $g->{nodes};
123 62         353 delete $g->{edges};
124             }
125             }
126             }
127              
128             # Attribute overlay for HTML output:
129              
130             my $html_att = {
131             node => {
132             borderstyle => 'solid',
133             borderwidth => '1px',
134             bordercolor => '#000000',
135             align => 'center',
136             padding => '0.2em',
137             'padding-left' => '0.3em',
138             'padding-right' => '0.3em',
139             margin => '0.1em',
140             fill => 'white',
141             },
142             'node.anon' => {
143             'borderstyle' => 'none',
144             # ' inherit' to protect the value from being replaced by the one from "node"
145             'background' => ' inherit',
146             },
147             graph => {
148             margin => '0.5em',
149             padding => '0.5em',
150             'empty-cells' => 'show',
151             },
152             edge => {
153             border => 'none',
154             padding => '0.2em',
155             margin => '0.1em',
156             'font' => 'monospaced, courier-new, courier, sans-serif',
157             'vertical-align' => 'bottom',
158             },
159             group => {
160             'borderstyle' => 'dashed',
161             'borderwidth' => '1',
162             'fontsize' => '0.8em',
163             fill => '#a0d0ff',
164             padding => '0.2em',
165             # XXX TODO:
166             # in HTML, align left is default, so we could omit this:
167             align => 'left',
168             },
169             'group.anon' => {
170             'borderstyle' => 'none',
171             background => 'white',
172             },
173             };
174              
175              
176             sub _init
177             {
178 909     909   842 my ($self,$args) = @_;
179              
180 909         1397 $self->{debug} = 0;
181 909         1008 $self->{timeout} = 5; # in seconds
182 909         906 $self->{strict} = 1; # check attributes strict?
183              
184 909         1035 $self->{class} = 'graph';
185 909         966 $self->{id} = '';
186 909         1104 $self->{groups} = {};
187              
188             # node objects, indexed by their unique name
189 909         1131 $self->{nodes} = {};
190             # edge objects, indexed by unique ID
191 909         1588 $self->{edges} = {};
192              
193 909         1034 $self->{output_format} = 'html';
194              
195 909         1051 $self->{_astar_bias} = 0.001;
196              
197             # default classes to use in add_foo() methods
198             $self->{use_class} = {
199 909         1991 edge => 'Graph::Easy::Edge',
200             group => 'Graph::Easy::Group',
201             node => 'Graph::Easy::Node',
202             };
203              
204             # Graph::Easy will die, Graph::Easy::Parser::Graphviz will warn
205 909         974 $self->{_warn_on_unknown_attributes} = 0;
206 909         842 $self->{fatal_errors} = 1;
207              
208             # The attributes of the graph itself, _and_ the class/subclass attributes.
209             # These can share a hash, because:
210             # * {att}->{graph} contains both the graph attributes and the class, since
211             # these are synonymous, it is not possible to have more than one graph.
212             # * 'node', 'group', 'edge' are not valid attributes for a graph, so
213             # setting "graph { node: 1; }" is not possible and can thus not overwrite
214             # the entries from att->{node}.
215             # * likewise for "node.subclass", attribute names never have a "." in them
216 909         1067 $self->{att} = {};
217              
218 909         3301 foreach my $k (sort keys %$args)
219             {
220 2407 50       6055 if ($k !~ /^(timeout|debug|strict|fatal_errors|undirected)\z/)
221             {
222 0         0 $self->error ("Unknown option '$k'");
223             }
224 2407 50 66     3064 if ($k eq 'undirected' && $args->{$k})
225             {
226 1         2 $self->set_attribute('type', 'undirected'); next;
  1         2  
227             }
228 2406         2574 $self->{$k} = $args->{$k};
229             }
230              
231             binmode(STDERR,'utf8') or die ("Cannot do binmode(STDERR,'utf8'")
232 909 50 0     1817 if $self->{debug};
233              
234 909         1040 $self->{score} = undef;
235              
236 909         1537 $self->randomize();
237              
238 909         2237 $self;
239             }
240              
241             #############################################################################
242             # accessors
243              
244             sub timeout
245             {
246 199     199 1 261 my $self = shift;
247              
248 199 100       602 $self->{timeout} = $_[0] if @_;
249 199         254 $self->{timeout};
250             }
251              
252             sub debug
253             {
254 47     47 1 28466 my $self = shift;
255              
256 47 50       149 $self->{debug} = $_[0] if @_;
257 47         64 $self->{debug};
258             }
259              
260             sub strict
261             {
262 442     442 1 414 my $self = shift;
263              
264 442 100       895 $self->{strict} = $_[0] if @_;
265 442         525 $self->{strict};
266             }
267              
268             sub type
269             {
270             # return the type of the graph, "undirected" or "directed"
271 20     20 1 19 my $self = shift;
272              
273 20 50       82 $self->{att}->{type} || 'directed';
274             }
275              
276             sub is_simple
277             {
278             # return true if the graph does not have multiedges
279 13     13 1 23 my $self = shift;
280              
281 13         12 my %count;
282 13         28 for my $e (ord_values ( $self->{edges} ))
283             {
284 26         35 my $id = "$e->{to}->{id},$e->{from}->{id}";
285 26 100       43 return 0 if exists $count{$id};
286 23         26 $count{$id} = undef;
287             }
288              
289 10         39 1; # found none
290             }
291              
292             sub is_directed
293             {
294             # return true if the graph is directed
295 4     4 1 4 my $self = shift;
296              
297 4 100       10 $self->attribute('type') eq 'directed' ? 1 : 0;
298             }
299              
300             sub is_undirected
301             {
302             # return true if the graph is undirected
303 4     4 1 5 my $self = shift;
304              
305 4 100       9 $self->attribute('type') eq 'undirected' ? 1 : 0;
306             }
307              
308             sub id
309             {
310 2     2 1 4 my $self = shift;
311              
312 2 100       6 $self->{id} = shift if defined $_[0];
313 2         5 $self->{id};
314             }
315              
316             sub score
317             {
318 0     0 1 0 my $self = shift;
319              
320 0         0 $self->{score};
321             }
322              
323             sub randomize
324             {
325 909     909 1 836 my $self = shift;
326              
327 909         18909 srand();
328 909         3034 $self->{seed} = rand(2 ** 31);
329              
330 909         1135 $self->{seed};
331             }
332              
333             sub root_node
334             {
335             # Return the root node
336 502     502 1 430 my $self = shift;
337              
338 502         719 my $root = $self->{att}->{root};
339 502 50       792 $root = $self->{nodes}->{$root} if defined $root;
340              
341 502         668 $root;
342             }
343              
344             sub source_nodes
345             {
346             # return nodes with only outgoing edges
347 0     0 1 0 my $self = shift;
348              
349 0         0 my @roots;
350 0         0 for my $node (ord_values ( $self->{nodes} ))
351             {
352             push @roots, $node
353 0 0 0     0 if (keys %{$node->{edges}} != 0) && !$node->has_predecessors();
  0         0  
354             }
355 0         0 @roots;
356             }
357              
358             sub predecessorless_nodes
359             {
360             # return nodes with no incoming (but maybe outgoing) edges
361 0     0 1 0 my $self = shift;
362              
363 0         0 my @roots;
364 0         0 for my $node (ord_values ( $self->{nodes} ))
365             {
366             push @roots, $node
367 0 0 0     0 if (keys %{$node->{edges}} == 0) || !$node->has_predecessors();
  0         0  
368             }
369 0         0 @roots;
370             }
371              
372             sub label
373             {
374 305     305 1 329 my $self = shift;
375              
376 305 100       478 my $label = $self->{att}->{graph}->{label}; $label = '' unless defined $label;
  305         638  
377 305 100 66     1120 $label = $self->_un_escape($label) if !$_[0] && $label =~ /\\[EGHNT]/;
378 305         469 $label;
379             }
380              
381             sub link
382             {
383             # return the link, build from linkbase and link (or autolink)
384 409     409 1 317 my $self = shift;
385              
386 409         539 my $link = $self->attribute('link');
387 409 100       406 my $autolink = ''; $autolink = $self->attribute('autolink') if $link eq '';
  409         951  
388 409 100 66     1217 if ($link eq '' && $autolink ne '')
389             {
390 391 100       592 $link = $self->{name} if $autolink eq 'name';
391             # defined to avoid overriding "name" with the non-existent label attribute
392 391 50 33     624 $link = $self->{att}->{label} if $autolink eq 'label' && defined $self->{att}->{label};
393 391 50 33     666 $link = $self->{name} if $autolink eq 'label' && !defined $self->{att}->{label};
394             }
395 409 100       547 $link = '' unless defined $link;
396              
397             # prepend base only if link is relative
398 409 100 100     1003 if ($link ne '' && $link !~ /^([\w]{3,4}:\/\/|\/)/)
399             {
400 85         140 $link = $self->attribute('linkbase') . $link;
401             }
402              
403 409 50 33     1221 $link = $self->_un_escape($link) if !$_[0] && $link =~ /\\[EGHNT]/;
404              
405 409         618 $link;
406             }
407              
408             sub parent
409             {
410             # return parent object, for graphs that is undef
411 52     52 1 73 undef;
412             }
413              
414             sub seed
415             {
416 0     0 1 0 my $self = shift;
417              
418 0 0       0 $self->{seed} = $_[0] if @_ > 0;
419              
420 0         0 $self->{seed};
421             }
422              
423             sub nodes
424             {
425             # return all nodes as objects, in scalar context their count
426 853     853 1 6006 my ($self) = @_;
427              
428 853         837 my $n = $self->{nodes};
429              
430 853 100       2228 return scalar keys %$n unless wantarray; # shortcut
431              
432 424         640 return ord_values ( $n );
433             }
434              
435             sub anon_nodes
436             {
437             # return all anon nodes as objects
438 1     1 1 2 my ($self) = @_;
439              
440 1         2 my $n = $self->{nodes};
441              
442 1 50       3 if (!wantarray)
443             {
444 1         2 my $count = 0;
445 1         2 for my $node (ord_values ($n))
446             {
447 0 0       0 $count++ if $node->is_anon();
448             }
449 1         3 return $count;
450             }
451              
452 0         0 my @anon = ();
453 0         0 for my $node (ord_values ( $n))
454             {
455 0 0       0 push @anon, $node if $node->is_anon();
456             }
457 0         0 @anon;
458             }
459              
460             sub edges
461             {
462             # Return all the edges this graph contains as objects
463 499     499 1 1343 my ($self) = @_;
464              
465 499         430 my $e = $self->{edges};
466              
467 499 100       734 return scalar keys %$e unless wantarray; # shortcut
468              
469 463         638 ord_values ($e);
470             }
471              
472             sub edges_within
473             {
474             # return all the edges as objects
475 0     0 1 0 my ($self) = @_;
476              
477 0         0 my $e = $self->{edges};
478              
479 0 0       0 return scalar keys %$e unless wantarray; # shortcut
480              
481 0         0 ord_values ($e);
482             }
483              
484             sub sorted_nodes
485             {
486             # return all nodes as objects, sorted by $f1 or $f1 and $f2
487 1056     1056 1 6870 my ($self, $f1, $f2) = @_;
488              
489 1056 50       1646 return scalar keys %{$self->{nodes}} unless wantarray; # shortcut
  0         0  
490              
491 1056 100       1539 $f1 = 'id' unless defined $f1;
492             # sorting on a non-unique field alone will result in unpredictable
493             # sorting order due to hashing
494 1056 100 66     3355 $f2 = 'name' if !defined $f2 && $f1 !~ /^(name|id)$/;
495              
496 1056         747 my $sort;
497 1056 50   3234   3242 $sort = sub { $a->{$f1} <=> $b->{$f1} } if $f1;
  3234         5383  
498 1056 100 66 0   4038 $sort = sub { abs($a->{$f1}) <=> abs($b->{$f1}) } if $f1 && $f1 eq 'rank';
  0         0  
499 1056 100 66 0   4247 $sort = sub { $a->{$f1} cmp $b->{$f1} } if $f1 && $f1 =~ /^(name|title|label)$/;
  0         0  
500 1056 0   0   2320 $sort = sub { $a->{$f1} <=> $b->{$f1} || $a->{$f2} <=> $b->{$f2} } if $f2;
  0 100       0  
501 1056 100 100 4   3072 $sort = sub { abs($a->{$f1}) <=> abs($b->{$f1}) || $a->{$f2} <=> $b->{$f2} } if $f2 && $f1 eq 'rank';
  4 100       13  
502 1056 0 66 0   2368 $sort = sub { $a->{$f1} <=> $b->{$f1} || abs($a->{$f2}) <=> abs($b->{$f2}) } if $f2 && $f2 eq 'rank';
  0 50       0  
503 1056 0 100 0   2894 $sort = sub { $a->{$f1} <=> $b->{$f1} || $a->{$f2} cmp $b->{$f2} } if $f2 &&
  0 100       0  
504             $f2 =~ /^(name|title|label)$/;
505 1256 100   1256   3589 $sort = sub { abs($a->{$f1}) <=> abs($b->{$f1}) || $a->{$f2} cmp $b->{$f2} } if
506 1056 100 66     4744 $f1 && $f1 eq 'rank' &&
      66        
      100        
507             $f2 && $f2 =~ /^(name|title|label)$/;
508             # 'name', 'id'
509 1056 50 100 1258   3413 $sort = sub { $a->{$f1} cmp $b->{$f1} || $a->{$f2} <=> $b->{$f2} } if $f2 &&
  1258 100 100     2920  
510             $f2 eq 'id' && $f1 ne 'rank';
511              
512             # the 'return' here should not be removed
513 1056         1166 return sort $sort values %{$self->{nodes}};
  1056         3933  
514             }
515              
516             sub add_edge_once
517             {
518             # add an edge, unless it already exists. In that case it returns undef
519 1     1 1 2 my ($self, $x, $y, $edge) = @_;
520              
521             # got an edge object? Don't add it twice!
522 1 50       2 return undef if ref($edge);
523              
524             # turn plaintext scalars into objects
525 1 50       3 my $x1 = $self->{nodes}->{$x} unless ref $x;
526 1 50       2 my $y1 = $self->{nodes}->{$y} unless ref $y;
527              
528             # nodes do exist => maybe the edge also exists
529 1 50 33     6 if (ref($x1) && ref($y1))
530             {
531 1         3 my @ids = $x1->edges_to($y1);
532              
533 1 50       4 return undef if @ids; # found already one edge?
534             }
535              
536 0         0 $self->add_edge($x,$y,$edge);
537             }
538              
539             sub edge
540             {
541             # return an edge between two nodes as object
542 534     534 1 531 my ($self, $x, $y) = @_;
543              
544             # turn plaintext scalars into objects
545 534 100       903 $x = $self->{nodes}->{$x} unless ref $x;
546 534 100       788 $y = $self->{nodes}->{$y} unless ref $y;
547              
548             # node does not exist => edge does not exist
549 534 50 33     1684 return undef unless ref($x) && ref($y);
550              
551 534         1023 my @ids = $x->edges_to($y);
552              
553 534 100       1197 wantarray ? @ids : $ids[0];
554             }
555              
556             sub flip_edges
557             {
558             # turn all edges going from $x to $y around
559 0     0 1 0 my ($self, $x, $y) = @_;
560              
561             # turn plaintext scalars into objects
562 0 0       0 $x = $self->{nodes}->{$x} unless ref $x;
563 0 0       0 $y = $self->{nodes}->{$y} unless ref $y;
564              
565             # node does not exist => edge does not exist
566             # if $x == $y, return early (no need to turn selfloops)
567              
568 0 0 0     0 return $self unless ref($x) && ref($y) && ($x != $y);
      0        
569              
570 0         0 for my $e (ord_values ( $x->{edges} ))
571             {
572 0 0 0     0 $e->flip() if $e->{from} == $x && $e->{to} == $y;
573             }
574              
575 0         0 $self;
576             }
577              
578             sub node
579             {
580             # return node by name
581 416     416 1 5266 my ($self,$name) = @_;
582 416 50       573 $name = '' unless defined $name;
583              
584 416         730 $self->{nodes}->{$name};
585             }
586              
587             sub rename_node
588             {
589             # change the name of a node
590 5     5 1 625 my ($self, $node, $new_name) = @_;
591              
592 5 100       15 $node = $self->{nodes}->{$node} unless ref($node);
593              
594 5 100       16 if (!ref($node))
595             {
596 1         2 $node = $self->add_node($new_name);
597             }
598             else
599             {
600 4 100       9 if (!ref($node->{graph}))
601             {
602             # add node to ourself
603 1         1 $node->{name} = $new_name;
604 1         2 $self->add_node($node);
605             }
606             else
607             {
608 3 100       10 if ($node->{graph} != $self)
609             {
610 1         3 $node->{graph}->del_node($node);
611 1         2 $node->{name} = $new_name;
612 1         1 $self->add_node($node);
613             }
614             else
615             {
616 2         6 delete $self->{nodes}->{$node->{name}};
617 2         3 $node->{name} = $new_name;
618 2         4 $self->{nodes}->{$node->{name}} = $node;
619             }
620             }
621             }
622 5 50       13 if ($node->is_anon())
623             {
624             # turn anon nodes into a normal node (since it got a new name):
625 0   0     0 bless $node, $self->{use_class}->{node} || 'Graph::Easy::Node';
626 0 0       0 delete $node->{att}->{label} if $node->{att}->{label} eq ' ';
627 0         0 $node->{class} = 'group';
628             }
629 5         8 $node;
630             }
631              
632             sub rename_group
633             {
634             # change the name of a group
635 0     0 1 0 my ($self, $group, $new_name) = @_;
636              
637 0 0       0 if (!ref($group))
638             {
639 0         0 $group = $self->add_group($new_name);
640             }
641             else
642             {
643 0 0       0 if (!ref($group->{graph}))
644             {
645             # add node to ourself
646 0         0 $group->{name} = $new_name;
647 0         0 $self->add_group($group);
648             }
649             else
650             {
651 0 0       0 if ($group->{graph} != $self)
652             {
653 0         0 $group->{graph}->del_group($group);
654 0         0 $group->{name} = $new_name;
655 0         0 $self->add_group($group);
656             }
657             else
658             {
659 0         0 delete $self->{groups}->{$group->{name}};
660 0         0 $group->{name} = $new_name;
661 0         0 $self->{groups}->{$group->{name}} = $group;
662             }
663             }
664             }
665 0 0       0 if ($group->is_anon())
666             {
667             # turn anon groups into a normal group (since it got a new name):
668 0   0     0 bless $group, $self->{use_class}->{group} || 'Graph::Easy::Group';
669 0 0       0 delete $group->{att}->{label} if $group->{att}->{label} eq '';
670 0         0 $group->{class} = 'group';
671             }
672 0         0 $group;
673             }
674              
675             #############################################################################
676             # attribute handling
677              
678             sub _check_class
679             {
680             # Check the given class ("graph", "node.foo" etc.) or class selector
681             # (".foo") for being valid, and return a list of base classes this applies
682             # to. Handles also a list of class selectors like ".foo, .bar, node.foo".
683 1781     1781   3144 my ($self, $selector) = @_;
684              
685 1781         3124 my @parts = split /\s*,\s*/, $selector;
686              
687 1781         1495 my @classes = ();
688 1781         1593 for my $class (@parts)
689             {
690             # allowed classes, subclasses (except "graph."), selectors (excpet ".")
691 1797 100       4152 return unless $class =~ /^(\.\w|node|group|edge|graph\z)/;
692             # "node." is invalid, too
693 1794 100       2667 return if $class =~ /\.\z/;
694              
695             # run a loop over all classes: "node.foo" => ("node"), ".foo" => ("node","edge","group")
696 1793         2139 $class =~ /^(\w*)/;
697 1793         2066 my $base_class = $1;
698 1793 100       2183 if ($base_class eq '')
699             {
700 10         27 push @classes, ('edge'.$class, 'group'.$class, 'node'.$class);
701             }
702             else
703             {
704 1783         2348 push @classes, $class;
705             }
706             } # end for all parts
707              
708 1777         2572 @classes;
709             }
710              
711             sub set_attribute
712             {
713 1426     1426 1 13801 my ($self, $class_selector, $name, $val) = @_;
714              
715             # allow calling in the style of $graph->set_attribute($name,$val);
716 1426 100       2180 if (@_ == 3)
717             {
718 551         419 $val = $name;
719 551         378 $name = $class_selector;
720 551         487 $class_selector = 'graph';
721             }
722              
723             # font-size => fontsize
724 1426 100       2150 $name = $att_aliases->{$name} if exists $att_aliases->{$name};
725              
726 1426 50       1794 $name = 'undef' unless defined $name;
727 1426 50       1597 $val = 'undef' unless defined $val;
728              
729 1426         1927 my @classes = $self->_check_class($class_selector);
730              
731 1426 50       2029 return $self->error ("Illegal class '$class_selector' when trying to set attribute '$name' to '$val'")
732             if @classes == 0;
733              
734 1426         1290 for my $class (@classes)
735             {
736 1426         2538 $val = $self->unquote_attribute($class,$name,$val);
737              
738 1426 100       2163 if ($self->{strict})
739             {
740 97         197 my ($rc, $newname, $v) = $self->validate_attribute($name,$val,$class);
741 97 100       188 return if defined $rc; # error?
742              
743 96         95 $val = $v;
744             }
745              
746 1425         1445 $self->{score} = undef; # invalidate layout to force a new layout
747 1425         1174 delete $self->{cache}; # setting a class or flow must invalidate the cache
748              
749             # handle special attribute 'gid' like in "graph { gid: 123; }"
750 1425 100       1923 if ($class eq 'graph')
751             {
752 674 50       1121 if ($name =~ /^g?id\z/)
753             {
754 0         0 $self->{id} = $val;
755             }
756             # handle special attribute 'output' like in "graph { output: ascii; }"
757 674 100       966 if ($name eq 'output')
758             {
759 2         2 $self->{output_format} = $val;
760             }
761             }
762              
763 1425         1127 my $att = $self->{att};
764             # create hash if it doesn't exist yet
765 1425 100       2673 $att->{$class} = {} unless ref $att->{$class};
766              
767 1425 100       2139 if ($name eq 'border')
768             {
769 8         10 my $c = $att->{$class};
770              
771 8         22 ($c->{borderstyle}, $c->{borderwidth}, $c->{bordercolor}) =
772             $self->split_border_attributes( $val );
773              
774 8         23 return $val;
775             }
776              
777 1417         2210 $att->{$class}->{$name} = $val;
778              
779             } # end for all selected classes
780              
781 1417         1916 $val;
782             }
783              
784             sub set_attributes
785             {
786 138     138 1 183 my ($self, $class_selector, $att) = @_;
787              
788             # if called as $graph->set_attributes( { color => blue } ), assume
789             # class eq 'graph'
790              
791 138 100 66     540 if (defined $class_selector && !defined $att)
792             {
793 22         19 $att = $class_selector; $class_selector = 'graph';
  22         22  
794             }
795              
796 138         278 my @classes = $self->_check_class($class_selector);
797              
798 138 50       274 return $self->error ("Illegal class '$class_selector' when trying to set attributes")
799             if @classes == 0;
800              
801 138         362 foreach my $a (sort keys %$att)
802             {
803 156         179 for my $class (@classes)
804             {
805 164         355 $self->set_attribute($class, $a, $att->{$a});
806             }
807             }
808 138         236 $self;
809             }
810              
811             sub del_attribute
812             {
813             # delete the attribute with the name in the selected class(es)
814 197     197 1 753 my ($self, $class_selector, $name) = @_;
815              
816 197 100       277 if (@_ == 2)
817             {
818 1         1 $name = $class_selector; $class_selector = 'graph';
  1         2  
819             }
820              
821             # font-size => fontsize
822 197 100       278 $name = $att_aliases->{$name} if exists $att_aliases->{$name};
823              
824 197         214 my @classes = $self->_check_class($class_selector);
825              
826 197 50       274 return $self->error ("Illegal class '$class_selector' when trying to delete attribute '$name'")
827             if @classes == 0;
828              
829 197         188 for my $class (@classes)
830             {
831 197         182 my $a = $self->{att}->{$class};
832              
833 197         193 delete $a->{$name};
834 197 50       252 if ($name eq 'size')
835             {
836 0         0 delete $a->{rows};
837 0         0 delete $a->{columns};
838             }
839 197 50       310 if ($name eq 'border')
840             {
841 0         0 delete $a->{borderstyle};
842 0         0 delete $a->{borderwidth};
843 0         0 delete $a->{bordercolor};
844             }
845             }
846 197         236 $self;
847             }
848              
849             #############################################################################
850              
851             # for determining the absolute graph flow
852             my $p_flow =
853             {
854             'east' => 90,
855             'west' => 270,
856             'north' => 0,
857             'south' => 180,
858             'up' => 0,
859             'down' => 180,
860             'back' => 270,
861             'left' => 270,
862             'right' => 90,
863             'front' => 90,
864             'forward' => 90,
865             };
866              
867             sub flow
868             {
869             # return out flow as number
870 279     279 1 314 my ($self) = @_;
871              
872 279         494 my $flow = $self->{att}->{graph}->{flow};
873              
874 279 100       769 return 90 unless defined $flow;
875              
876 86 100       157 my $f = $p_flow->{$flow}; $f = $flow unless defined $f;
  86         141  
877 86         138 $f;
878             }
879              
880             #############################################################################
881             #############################################################################
882             # Output (as_ascii, as_html) routines; as_txt() is in As_txt.pm, as_graphml
883             # is in As_graphml.pm
884              
885             sub output_format
886             {
887             # set the output format
888 4     4 1 8 my $self = shift;
889              
890 4 50       22 $self->{output_format} = shift if $_[0];
891 4         12 $self->{output_format};
892             }
893              
894             sub output
895             {
896             # general output routine, to output the graph as the format that was
897             # specified in the graph source itself
898 5     5 1 7 my $self = shift;
899              
900 48     48   256 no strict 'refs';
  48         61  
  48         211847  
901              
902 5         11 my $method = 'as_' . $self->{output_format};
903              
904 5 50       25 $self->_croak("Cannot find a method to generate '$self->{output_format}'")
905             unless $self->can($method);
906              
907 5         13 $self->$method();
908             }
909              
910             sub _class_styles
911             {
912             # Create the style sheet with the class lists. This is used by both
913             # css() and as_svg(). $skip is a qr// object that returns true for
914             # attribute names to be skipped (e.g. excluded), and $map is a
915             # HASH that contains mapping for attribute names for the output.
916             # "$base" is the basename for classes (either "table.graph$id" if
917             # not defined, or whatever you pass in, like "" for svg).
918             # $indent is a left-indenting spacer like " ".
919             # $overlay contains a HASH with attribute-value pairs to set as defaults.
920              
921 20     20   24 my ($self, $skip, $map, $base, $indent, $overlay) = @_;
922              
923 20         22 my $a = $self->{att};
924              
925 20 50       41 $indent = '' unless defined $indent;
926 20 50       27 my $indent2 = $indent x 2; $indent2 = ' ' if $indent2 eq '';
  20         39  
927              
928 20         49 my $class_list = { edge => {}, node => {}, group => {} };
929 20 50       40 if (defined $overlay)
930             {
931 20         17 $a = {};
932              
933             # make a copy from $self->{att} to $a:
934              
935 20         16 for my $class (sort keys %{$self->{att}})
  20         73  
936             {
937 47         31 my $ac = $self->{att}->{$class};
938 47         50 $a->{$class} = {};
939 47         37 my $acc = $a->{$class};
940 47         62 for my $k (sort keys %$ac)
941             {
942 40         65 $acc->{$k} = $ac->{$k};
943             }
944             }
945              
946             # add the extra keys
947 20         64 for my $class (sort keys %$overlay)
948             {
949 120         95 my $oc = $overlay->{$class};
950             # create the hash if it doesn't exist yet
951 120 100       182 $a->{$class} = {} unless ref $a->{$class};
952 120         82 my $acc = $a->{$class};
953 120         254 for my $k (sort keys %$oc)
954             {
955 540 50       823 $acc->{$k} = $oc->{$k} unless exists $acc->{$k};
956             }
957 120         155 $class_list->{$class} = {};
958             }
959             }
960              
961 20         27 my $id = $self->{id};
962              
963 20         71 my @primaries = sort keys %$class_list;
964 20         24 foreach my $primary (@primaries)
965             {
966 120         99 my $cl = $class_list->{$primary}; # shortcut
967 120         249 foreach my $class (sort keys %$a)
968             {
969 738 100       2150 if ($class =~ /^$primary\.(.*)/)
970             {
971 43         94 $cl->{$1} = undef; # note w/o doubles
972             }
973             }
974             }
975              
976 20 50       47 $base = "table.graph$id " unless defined $base;
977              
978 20         49 my $groups = $self->groups(); # do we have groups?
979              
980 20         22 my $css = '';
981 20         45 foreach my $class (sort keys %$a)
982             {
983 123 50       267 next if (not %{$a->{$class}}); # skip empty ones
  123         363  
984              
985 123         116 my $c = $class; $c =~ s/\./_/g; # node.city => node_city
  123         180  
986              
987 123 100 100     235 next if $class eq 'group' and $groups == 0;
988              
989 107         75 my $css_txt = '';
990 107         68 my $cls = '';
991 107 50 66     258 if ($class eq 'graph' && $base eq '')
    100          
992             {
993 0         0 $css_txt .= "${indent}.$class \{\n"; # for SVG
994             }
995             elsif ($class eq 'graph')
996             {
997 20         23 $css_txt .= "$indent$base\{\n";
998             }
999             else
1000             {
1001 87 50       113 if ($c !~ /\./) # one of our primary ones
1002             {
1003             # generate also class list # like: "cities,node_rivers"
1004 87         100 $cls = join (",$base.${c}_", sort keys %{ $class_list->{$c} });
  87         260  
1005 87 100       143 $cls = ",$base.${c}_$cls" if $cls ne ''; # like: ",node_cities,node_rivers"
1006             }
1007 87         113 $css_txt .= "$indent$base.$c$cls {\n";
1008             }
1009 107         82 my $done = 0;
1010 107         64 foreach my $att (sort keys %{$a->{$class}})
  107         319  
1011             {
1012             # should be skipped?
1013 484 100 100     2378 next if $att =~ $skip || $att eq 'border';
1014              
1015             # do not specify attributes for the entire graph (only for the label)
1016             # $base ne '' skips this rule for SVG output
1017 442 100 66     832 next if $class eq 'graph' && $base ne '' && $att =~ /^(color|font|fontsize|align|fill)\z/;
      100        
1018              
1019 432         245 $done++; # how many did we really?
1020 432         387 my $val = $a->{$class}->{$att};
1021              
1022 432 50       489 next if !defined $val;
1023              
1024             # for groups, set to none, it will be later overriden for the different
1025             # cells (like "ga") with a border only on the appropriate side:
1026 432 100 100     671 $val = 'none' if $att eq 'borderstyle' && $class eq 'group';
1027             # fix border-widths to be in pixel
1028 432 100 100     650 $val .= 'px' if $att eq 'borderwidth' && $val !~ /(px|em|%)\z/;
1029              
1030             # for color attributes, convert to hex
1031 432         648 my $entry = $self->_attribute_entry($class, $att);
1032              
1033 432 100       534 if (defined $entry)
1034             {
1035 228   100     451 my $type = $entry->[ ATTR_TYPE_SLOT ] || ATTR_STRING;
1036 228 100       284 if ($type == ATTR_COLOR)
1037             {
1038             # create as RGB color
1039 92   66     153 $val = $self->get_color_attribute($class,$att) || $val;
1040             }
1041             }
1042             # change attribute name/value?
1043 432 100       530 if (exists $map->{$att})
1044             {
1045 181 100       271 $att = $map->{$att} unless ref $map->{$att}; # change attribute name?
1046 181 100       255 ($att,$val) = &{$map->{$att}}($self,$att,$val,$class) if ref $map->{$att};
  25         40  
1047             }
1048              
1049             # value is "inherit"?
1050 432 100 66     1908 if ($class ne 'graph' && $att && $val && $val eq 'inherit')
      66        
      66        
1051             {
1052             # get the value from one class "up"
1053              
1054             # node.foo => node, node => graph
1055 32 50       29 my $base_class = $class; $base_class = 'graph' unless $base_class =~ /\./;
  32         57  
1056 32         83 $base_class =~ s/\..*//;
1057              
1058 32         36 $val = $a->{$base_class}->{$att};
1059              
1060 32 50 33     92 if ($base_class ne 'graph' && (!defined $val || $val eq 'inherit'))
      33        
1061             {
1062             # node.foo => node, inherit => graph
1063 32         25 $val = $a->{graph}->{$att};
1064 32 50       51 $att = undef if !defined $val;
1065             }
1066             }
1067              
1068 432 100 66     1324 $css_txt .= "$indent2$att: $val;\n" if defined $att && defined $val;
1069             }
1070              
1071 107         178 $css_txt .= "$indent}\n";
1072 107 50       200 $css .= $css_txt if $done > 0; # skip if no attributes at all
1073             }
1074 20         159 $css;
1075             }
1076              
1077             sub _skip
1078             {
1079             # return a regexp that specifies which attributes to suppress in CSS
1080 20     20   23 my ($self) = shift;
1081              
1082             # skip these for CSS
1083 20         177 qr/^(basename|columns|colorscheme|comment|class|flow|format|group|rows|root|size|offset|origin|linkbase|(auto)?(label|link|title)|auto(join|split)|(node|edge)class|shape|arrowstyle|label(color|pos)|point(style|shape)|textstyle|style)\z/;
1084             }
1085              
1086             #############################################################################
1087             # These routines are used by as_html for the generation of CSS
1088              
1089             sub _remap_text_wrap
1090             {
1091 1     1   2 my ($self,$name,$style) = @_;
1092              
1093 1 50       4 return (undef,undef) if $style ne 'auto';
1094              
1095             # make text wrap again
1096 0         0 ('white-space','normal');
1097             }
1098              
1099             sub _remap_fill
1100             {
1101 25     25   32 my ($self,$name,$color,$class) = @_;
1102              
1103 25 50       89 return ('background',$color) unless $class =~ /edge/;
1104              
1105             # for edges, the fill is ignored
1106 0         0 (undef,undef);
1107             }
1108              
1109             #############################################################################
1110              
1111             sub css
1112             {
1113 20     20 1 26 my $self = shift;
1114              
1115 20         20 my $a = $self->{att};
1116 20         24 my $id = $self->{id};
1117              
1118             # for each primary class (node/group/edge) we need to find all subclasses,
1119             # and list them in the CSS, too. Otherwise "node_city" would not inherit
1120             # the attributes from "node".
1121              
1122 20         39 my $css = $self->_class_styles( $self->_skip(),
1123             {
1124             fill => \&_remap_fill,
1125             textwrap => \&_remap_text_wrap,
1126             align => 'text-align',
1127             font => 'font-family',
1128             fontsize => 'font-size',
1129             bordercolor => 'border-color',
1130             borderstyle => 'border-style',
1131             borderwidth => 'border-width',
1132             },
1133             undef,
1134             undef,
1135             $html_att,
1136             );
1137              
1138 20         71 my @groups = $self->groups();
1139              
1140             # Set attributes for all TDs that start with "group":
1141 20 100       40 $css .= <
1142             table.graph##id## td[class|="group"] { padding: 0.2em; }
1143             CSS
1144             if @groups > 0;
1145              
1146 20         28 $css .= <
1147             table.graph##id## td {
1148             padding: 2px;
1149             background: inherit;
1150             white-space: nowrap;
1151             }
1152             table.graph##id## span.l { float: left; }
1153             table.graph##id## span.r { float: right; }
1154             CSS
1155             ;
1156              
1157             # append CSS for edge cells (and their parts like va (vertical arrow
1158             # (left/right), vertical empty), etc)
1159              
1160             # eb - empty bottom or arrow pointing down/up
1161             # el - (vertical) empty left space of ver edge
1162             # or empty vertical space on hor edge starts
1163             # lh - edge label horizontal
1164             # le - edge label, but empty (no label)
1165             # lv - edge label vertical
1166             # sh - shifted arrow horizontal (shift right)
1167             # sa - shifted arrow horizontal (shift left for corners)
1168             # shl - shifted arrow horizontal (shift left)
1169             # sv - shifted arrow vertical (pointing down)
1170             # su - shifted arrow vertical (pointing up)
1171              
1172             $css .= <
1173             table.graph##id## .va {
1174             vertical-align: middle;
1175             line-height: 1em;
1176             width: 0.4em;
1177             }
1178             table.graph##id## .el {
1179             width: 0.1em;
1180             max-width: 0.1em;
1181             min-width: 0.1em;
1182             }
1183             table.graph##id## .lh, table.graph##id## .lv {
1184             font-size: 0.8em;
1185             padding-left: 0.4em;
1186             }
1187             table.graph##id## .sv, table.graph##id## .sh, table.graph##id## .shl, table.graph##id## .sa, table.graph##id## .su {
1188             max-height: 1em;
1189             line-height: 1em;
1190             position: relative;
1191             top: 0.55em;
1192             left: -0.3em;
1193             overflow: visible;
1194             }
1195             table.graph##id## .sv, table.graph##id## .su {
1196             max-height: 0.5em;
1197             line-height: 0.5em;
1198             }
1199             table.graph##id## .shl { left: 0.3em; }
1200             table.graph##id## .sv { left: -0.5em; top: -0.4em; }
1201             table.graph##id## .su { left: -0.5em; top: 0.4em; }
1202             table.graph##id## .sa { left: -0.3em; top: 0; }
1203             table.graph##id## .eb { max-height: 0; line-height: 0; height: 0; }
1204             CSS
1205             # if we have edges
1206 20 50       13 if keys %{$self->{edges}} > 0;
  20         73  
1207              
1208             # if we have nodes with rounded shapes:
1209 20         19 my $rounded = 0;
1210 20         54 for my $n (ord_values ( $self->{nodes} ))
1211             {
1212 56 100 100     106 $rounded ++ and last if $n->shape() =~ /circle|ellipse|rounded/;
1213             }
1214              
1215             $css .= <
1216             table.graph##id## span.c { position: relative; top: 1.5em; }
1217             table.graph##id## div.c { -moz-border-radius: 100%; border-radius: 100%; }
1218             table.graph##id## div.r { -moz-border-radius: 1em; border-radius: 1em; }
1219             CSS
1220 20 100       42 if $rounded > 0;
1221              
1222             # append CSS for group cells (only if we actually have groups)
1223              
1224 20 100       35 if (@groups > 0)
1225             {
1226 4         5 foreach my $group (@groups)
1227             {
1228 4         13 my $class = $group->class();
1229              
1230 4         12 my $border = $group->attribute('borderstyle');
1231              
1232 4         5 $class =~ s/.*\.//; # leave only subclass
1233 4         16 $css .= Graph::Easy::Group::Cell->_css($self->{id}, $class, $border);
1234             }
1235             }
1236              
1237             # replace the id with either '' or '123', depending on our ID
1238 20         209 $css =~ s/##id##/$id/g;
1239              
1240 20         61 $css;
1241             }
1242              
1243             sub html_page_header
1244             {
1245             # return the HTML header for as_html_file()
1246 10     10 1 9 my ($self, $css) = @_;
1247              
1248 10         12 my $html = <
1249            
1250            
1251            
1252            
1253             ##title####CSS##
1254            
1255            
1256             HTML
1257             ;
1258              
1259 10         31 $html =~ s/\n\z//;
1260 10         32 $html =~ s/##charset##/utf-8/g;
1261 10         20 my $t = $self->title();
1262 10         29 $html =~ s/##title##/$t/g;
1263              
1264             # insert CSS if requested
1265 10 50       24 $css = $self->css() unless defined $css;
1266              
1267 10 50       67 $html =~ s/##CSS##/\n