File Coverage

lib/Graph/Easy.pm

Criterion	Covered	Total	%
statement	800	952	84.0
branch	361	518	69.6
condition	120	203	59.1
subroutine	91	114	79.8
pod	78	78	100.0
total	1450	1865	77.7

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	49			49		1167455	use 5.008002;
	49					208
	49					3106
9	49			49		13535	use Graph::Easy::Base;
	49					124
	49					1703
10	49			49		23663	use Graph::Easy::Attributes;
	49					185
	49					6336
11	49			49		33782	use Graph::Easy::Edge;
	49					169
	49					3704
12	49			49		27665	use Graph::Easy::Group;
	49					210
	49					2197
13	49			49		24440	use Graph::Easy::Group::Anon;
	49					128
	49					1707
14	49			49		21881	use Graph::Easy::Layout;
	49					169
	49					2024
15	49			49		404	use Graph::Easy::Node;
	49					109
	49					1210
16	49			49		30175	use Graph::Easy::Node::Anon;
	49					142
	49					1729
17	49			49		19836	use Graph::Easy::Node::Empty;
	49					131
	49					3358
18	49			49		513	use Scalar::Util qw/weaken/;
	49					112
	49					9301
19
20							$VERSION = '0.75';
21							@ISA = qw/Graph::Easy::Base/;
22
23	49			49		1666	use strict;
	49					127
	49					2597
24	49			49		273	use warnings;
	49					98
	49					3925
25							my $att_aliases;
26
27	49			49		267	use Graph::Easy::Util qw(ord_values);
	49					107
	49					17591
28
29							BEGIN
30							{
31							# a few aliases for backwards compatibility
32	49			49		295	*get_attribute = \&attribute;
33	49					355	*as_html_page = \&as_html_file;
34	49					381	*as_graphviz_file = \&as_graphviz;
35	49					299	*as_ascii_file = \&as_ascii;
36	49					329	*as_boxart_file = \&as_boxart;
37	49					307	*as_txt_file = \&as_txt;
38	49					311	*as_vcg_file = \&as_vcg;
39	49					301	*as_gdl_file = \&as_gdl;
40	49					294	*as_graphml_file = \&as_graphml;
41
42							# a few aliases for code re-use
43	49					215	*_aligned_label = \&Graph::Easy::Node::_aligned_label;
44	49					302	*quoted_comment = \&Graph::Easy::Node::quoted_comment;
45	49					217	*_un_escape = \&Graph::Easy::Node::_un_escape;
46	49					201	*_convert_pod = \&Graph::Easy::Node::_convert_pod;
47	49					238	*_label_as_html = \&Graph::Easy::Node::_label_as_html;
48	49					231	*_wrapped_label = \&Graph::Easy::Node::_wrapped_label;
49	49					217	*get_color_attribute = \&color_attribute;
50	49					230	*get_custom_attributes = \&Graph::Easy::Node::get_custom_attributes;
51	49					191	*custom_attributes = \&Graph::Easy::Node::get_custom_attributes;
52	49					295	$att_aliases = Graph::Easy::_att_aliases();
53
54							# backwards compatibility
55	49					335	*is_simple_graph = \&is_simple;
56
57							# compatibility to Graph
58	49					276572	*vertices = \&nodes;
59							}
60
61							#############################################################################
62
63							sub new
64							{
65							# override new() as to not set the {id}
66	912			912	1	101593	my $class = shift;
67
68							# called like "new->('[A]->[B]')":
69	912	100	100			6912	if (@_ == 1 && !ref($_[0]))
70							{
71	3					1279	require Graph::Easy::Parser;
72	3					42	my $parser = Graph::Easy::Parser->new();
73	3					8	my $self = eval { $parser->from_text($_[0]); };
	3					22
74	3	50				12	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					293	return $self;
82							}
83
84	909					3157	my $self = bless {}, $class;
85
86	909					1720	my $args = $_[0];
87	909	100				3153	$args = { @_ } if ref($args) ne 'HASH';
88
89	909					3544	$self->_init($args);
90							}
91
92							sub DESTROY
93							{
94	934			934		36512	my $self = shift;
95
96							# Be carefull 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					3123	delete $self->{chains};
100							# clean out pointers in child-objects so that they can safely be reused
101	934					9328	for my $n (ord_values ( $self->{nodes} ))
102							{
103	1511	50				5138	if (ref($n))
104							{
105	1511					4866	delete $n->{edges};
106	1511					3612	delete $n->{group};
107							}
108							}
109	934					4711	for my $e (ord_values ( $self->{edges} ))
110							{
111	1065	50				4022	if (ref($e))
112							{
113	1065					3445	delete $e->{cells};
114	1065					2736	delete $e->{to};
115	1065					2686	delete $e->{from};
116							}
117							}
118	934					13212	for my $g (ord_values ( $self->{groups} ))
119							{
120	62	50				215	if (ref($g))
121							{
122	62					183	delete $g->{nodes};
123	62					1018	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		2230	my ($self,$args) = @_;
179
180	909					2704	$self->{debug} = 0;
181	909					8783	$self->{timeout} = 5; # in seconds
182	909					2269	$self->{strict} = 1; # check attributes strict?
183
184	909					2187	$self->{class} = 'graph';
185	909					2252	$self->{id} = '';
186	909					3148	$self->{groups} = {};
187
188							# node objects, indexed by their unique name
189	909					2449	$self->{nodes} = {};
190							# edge objects, indexed by unique ID
191	909					10431	$self->{edges} = {};
192
193	909					2160	$self->{output_format} = 'html';
194
195	909					2568	$self->{_astar_bias} = 0.001;
196
197							# default classes to use in add_foo() methods
198	909					5498	$self->{use_class} = {
199							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					2156	$self->{_warn_on_unknown_attributes} = 0;
206	909					2186	$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					2459	$self->{att} = {};
217
218	909					6135	foreach my $k (sort keys %$args)
219							{
220	2407	50				21006	if ($k !~ /^(timeout\|debug\|strict\|fatal_errors\|undirected)\z/)
221							{
222	0					0	$self->error ("Unknown option '$k'");
223							}
224	2407	100	66			6802	if ($k eq 'undirected' && $args->{$k})
225							{
226	1					5	$self->set_attribute('type', 'undirected'); next;
	1					3
227							}
228	2406					5880	$self->{$k} = $args->{$k};
229							}
230
231	909	50	0			10845	binmode(STDERR,'utf8') or die ("Cannot do binmode(STDERR,'utf8'")
232							if $self->{debug};
233
234	909					2356	$self->{score} = undef;
235
236	909					19134	$self->randomize();
237
238	909					5281	$self;
239							}
240
241							#############################################################################
242							# accessors
243
244							sub timeout
245							{
246	199			199	1	572	my $self = shift;
247
248	199	100				2523	$self->{timeout} = $_[0] if @_;
249	199					871	$self->{timeout};
250							}
251
252							sub debug
253							{
254	47			47	1	514793	my $self = shift;
255
256	47	50				502	$self->{debug} = $_[0] if @_;
257	47					280	$self->{debug};
258							}
259
260							sub strict
261							{
262	442			442	1	1123	my $self = shift;
263
264	442	100				1967	$self->{strict} = $_[0] if @_;
265	442					1303	$self->{strict};
266							}
267
268							sub type
269							{
270							# return the type of the graph, "undirected" or "directed"
271	20			20	1	29	my $self = shift;
272
273	20	50				141	$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	35	my $self = shift;
280
281	13					16	my %count;
282	13					44	for my $e (ord_values ( $self->{edges} ))
283							{
284	26					51	my $id = "$e->{to}->{id},$e->{from}->{id}";
285	26	100				60	return 0 if exists $count{$id};
286	23					52	$count{$id} = undef;
287							}
288
289	10					66	1; # found none
290							}
291
292							sub is_directed
293							{
294							# return true if the graph is directed
295	4			4	1	5	my $self = shift;
296
297	4	100				17	$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	12	my $self = shift;
304
305	4	100				13	$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				9	$self->{id} = shift if defined $_[0];
313	2					12	$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	1981	my $self = shift;
326
327	909					54714	srand();
328	909					5347	$self->{seed} = rand(2 ** 31);
329
330	909					2517	$self->{seed};
331							}
332
333							sub root_node
334							{
335							# Return the root node
336	502			502	1	1141	my $self = shift;
337
338	502					1887	my $root = $self->{att}->{root};
339	502	50				1426	$root = $self->{nodes}->{$root} if defined $root;
340
341	502					1626	$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	0					0	push @roots, $node
353	0	0	0			0	if (keys %{$node->{edges}} != 0) && !$node->has_predecessors();
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	0					0	push @roots, $node
367	0	0	0			0	if (keys %{$node->{edges}} == 0) \|\| !$node->has_predecessors();
368							}
369	0					0	@roots;
370							}
371
372							sub label
373							{
374	305			305	1	658	my $self = shift;
375
376	305	100				1033	my $label = $self->{att}->{graph}->{label}; $label = '' unless defined $label;
	305					1051
377	305	100	66			2010	$label = $self->_un_escape($label) if !$_[0] && $label =~ /\\[EGHNT]/;
378	305					876	$label;
379							}
380
381							sub link
382							{
383							# return the link, build from linkbase and link (or autolink)
384	409			409	1	900	my $self = shift;
385
386	409					1160	my $link = $self->attribute('link');
387	409	100				893	my $autolink = ''; $autolink = $self->attribute('autolink') if $link eq '';
	409					1904
388	409	100	66			2181	if ($link eq '' && $autolink ne '')
389							{
390	391	100				1124	$link = $self->{name} if $autolink eq 'name';
391							# defined to avoid overriding "name" with the non-existant label attribute
392	391	50	33			1320	$link = $self->{att}->{label} if $autolink eq 'label' && defined $self->{att}->{label};
393	391	50	33			1288	$link = $self->{name} if $autolink eq 'label' && !defined $self->{att}->{label};
394							}
395	409	100				1191	$link = '' unless defined $link;
396
397							# prepend base only if link is relative
398	409	100	100			1896	if ($link ne '' && $link !~ /^([\w]{3,4}:\/\/\|\/)/)
399							{
400	85					446	$link = $self->attribute('linkbase') . $link;
401							}
402
403	409	50	33			2842	$link = $self->_un_escape($link) if !$_[0] && $link =~ /\\[EGHNT]/;
404
405	409					1369	$link;
406							}
407
408							sub parent
409							{
410							# return parent object, for graphs that is undef
411	52			52	1	122	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	14902	my ($self) = @_;
427
428	853					2081	my $n = $self->{nodes};
429
430	853	100				4927	return scalar keys %$n unless wantarray; # shortcut
431
432	424					2536	return ord_values ( $n );
433							}
434
435							sub anon_nodes
436							{
437							# return all anon nodes as objects
438	1			1	1	3	my ($self) = @_;
439
440	1					3	my $n = $self->{nodes};
441
442	1	50				5	if (!wantarray)
443							{
444	1					2	my $count = 0;
445	1					5	for my $node (ord_values ($n))
446							{
447	0	0				0	$count++ if $node->is_anon();
448							}
449	1					12	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	2528	my ($self) = @_;
464
465	499					1167	my $e = $self->{edges};
466
467	499	100				1333	return scalar keys %$e unless wantarray; # shortcut
468
469	463					1532	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	13790	my ($self, $f1, $f2) = @_;
488
489	1056	50				3786	return scalar keys %{$self->{nodes}} unless wantarray; # shortcut
	0					0
490
491	1056	100				3040	$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			8580	$f2 = 'name' if !defined $f2 && $f1 !~ /^(name\|id)$/;
495
496	1056					1656	my $sort;
497	1056	50		3241		7689	$sort = sub { $a->{$f1} <=> $b->{$f1} } if $f1;
	3241					25546
498	1056	100	66	0		8822	$sort = sub { abs($a->{$f1}) <=> abs($b->{$f1}) } if $f1 && $f1 eq 'rank';
	0					0
499	1056	100	66	0		9109	$sort = sub { $a->{$f1} cmp $b->{$f1} } if $f1 && $f1 =~ /^(name\|title\|label)$/;
	0					0
500	1056	0		0		6268	$sort = sub { $a->{$f1} <=> $b->{$f1} \|\| $a->{$f2} <=> $b->{$f2} } if $f2;
	0	100				0
501	1056	100	100	5		7227	$sort = sub { abs($a->{$f1}) <=> abs($b->{$f1}) \|\| $a->{$f2} <=> $b->{$f2} } if $f2 && $f1 eq 'rank';
	5	100				30
502	1056	0	66	0		6000	$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		8083	$sort = sub { $a->{$f1} <=> $b->{$f1} \|\| $a->{$f2} cmp $b->{$f2} } if $f2 &&
	0	100				0
504							$f2 =~ /^(name\|title\|label)$/;
505	1293	100		1293		8079	$sort = sub { abs($a->{$f1}) <=> abs($b->{$f1}) \|\| $a->{$f2} cmp $b->{$f2} } if
506	1056	100	66			12239	$f1 && $f1 eq 'rank' &&
			66
			100
507							$f2 && $f2 =~ /^(name\|title\|label)$/;
508							# 'name', 'id'
509	1056	50	100	1267		7531	$sort = sub { $a->{$f1} cmp $b->{$f1} \|\| $a->{$f2} <=> $b->{$f2} } if $f2 &&
	1267	100	100			7832
510							$f2 eq 'id' && $f1 ne 'rank';
511
512							# the 'return' here should not be removed
513	1056					3111	return sort $sort values %{$self->{nodes}};
	1056					10132
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	3	my ($self, $x, $y, $edge) = @_;
520
521							# got an edge object? Don't add it twice!
522	1	50				4	return undef if ref($edge);
523
524							# turn plaintext scalars into objects
525	1	50				5	my $x1 = $self->{nodes}->{$x} unless ref $x;
526	1	50				4	my $y1 = $self->{nodes}->{$y} unless ref $y;
527
528							# nodes do exist => maybe the edge also exists
529	1	50	33			12	if (ref($x1) && ref($y1))
530							{
531	1					6	my @ids = $x1->edges_to($y1);
532
533	1	50				6	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	961	my ($self, $x, $y) = @_;
543
544							# turn plaintext scalars into objects
545	534	100				1860	$x = $self->{nodes}->{$x} unless ref $x;
546	534	100				1196	$y = $self->{nodes}->{$y} unless ref $y;
547
548							# node does not exist => edge does not exist
549	534	50	33			2675	return undef unless ref($x) && ref($y);
550
551	534					2543	my @ids = $x->edges_to($y);
552
553	534	100				2264	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	23981	my ($self,$name) = @_;
582	416	50				1030	$name = '' unless defined $name;
583
584	416					5619	$self->{nodes}->{$name};
585							}
586
587							sub rename_node
588							{
589							# change the name of a node
590	5			5	1	2812	my ($self, $node, $new_name) = @_;
591
592	5	100				26	$node = $self->{nodes}->{$node} unless ref($node);
593
594	5	100				21	if (!ref($node))
595							{
596	1					4	$node = $self->add_node($new_name);
597							}
598							else
599							{
600	4	100				18	if (!ref($node->{graph}))
601							{
602							# add node to ourself
603	1					2	$node->{name} = $new_name;
604	1					3	$self->add_node($node);
605							}
606							else
607							{
608	3	100				12	if ($node->{graph} != $self)
609							{
610	1					6	$node->{graph}->del_node($node);
611	1					2	$node->{name} = $new_name;
612	1					4	$self->add_node($node);
613							}
614							else
615							{
616	2					7	delete $self->{nodes}->{$node->{name}};
617	2					6	$node->{name} = $new_name;
618	2					8	$self->{nodes}->{$node->{name}} = $node;
619							}
620							}
621							}
622	5	50				26	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					16	$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		6817	my ($self, $selector) = @_;
684
685	1781					6544	my @parts = split /\s,\s/, $selector;
686
687	1781					12021	my @classes = ();
688	1781					3202	for my $class (@parts)
689							{
690							# allowed classes, subclasses (except "graph."), selectors (excpet ".")
691	1797	100				7509	return unless $class =~ /^(\.\w\|node\|group\|edge\|graph\z)/;
692							# "node." is invalid, too
693	1794	100				4518	return if $class =~ /\.\z/;
694
695							# run a loop over all classes: "node.foo" => ("node"), ".foo" => ("node","edge","group")
696	1793					4418	$class =~ /^(\w*)/;
697	1793					4061	my $base_class = $1;
698	1793	100				4250	if ($base_class eq '')
699							{
700	10					39	push @classes, ('edge'.$class, 'group'.$class, 'node'.$class);
701							}
702							else
703							{
704	1783					5507	push @classes, $class;
705							}
706							} # end for all parts
707
708	1777					6171	@classes;
709							}
710
711							sub set_attribute
712							{
713	1426			1426	1	93376	my ($self, $class_selector, $name, $val) = @_;
714
715							# allow calling in the style of $graph->set_attribute($name,$val);
716	1426	100				3683	if (@_ == 3)
717							{
718	551					851	$val = $name;
719	551					722	$name = $class_selector;
720	551					944	$class_selector = 'graph';
721							}
722
723							# font-size => fontsize
724	1426	100				4326	$name = $att_aliases->{$name} if exists $att_aliases->{$name};
725
726	1426	50				3290	$name = 'undef' unless defined $name;
727	1426	50				3061	$val = 'undef' unless defined $val;
728
729	1426					16944	my @classes = $self->_check_class($class_selector);
730
731	1426	50				6471	return $self->error ("Illegal class '$class_selector' when trying to set attribute '$name' to '$val'")
732							if @classes == 0;
733
734	1426					2901	for my $class (@classes)
735							{
736	1426					7411	$val = $self->unquote_attribute($class,$name,$val);
737
738	1426	100				4319	if ($self->{strict})
739							{
740	97					382	my ($rc, $newname, $v) = $self->validate_attribute($name,$val,$class);
741	97	100				368	return if defined $rc; # error?
742
743	96					217	$val = $v;
744							}
745
746	1425					2384	$self->{score} = undef; # invalidate layout to force a new layout
747	1425					2481	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				5374	if ($class eq 'graph')
751							{
752	674	50				2322	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				3268	if ($name eq 'output')
758							{
759	2					9	$self->{output_format} = $val;
760							}
761							}
762
763	1425					2459	my $att = $self->{att};
764							# create hash if it doesn't exist yet
765	1425	100				4908	$att->{$class} = {} unless ref $att->{$class};
766
767	1425	100				3770	if ($name eq 'border')
768							{
769	8					23	my $c = $att->{$class};
770
771	8					43	($c->{borderstyle}, $c->{borderwidth}, $c->{bordercolor}) =
772							$self->split_border_attributes( $val );
773
774	8					45	return $val;
775							}
776
777	1417					5646	$att->{$class}->{$name} = $val;
778
779							} # end for all selected classes
780
781	1417					4391	$val;
782							}
783
784							sub set_attributes
785							{
786	138			138	1	924	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			902	if (defined $class_selector && !defined $att)
792							{
793	22					33	$att = $class_selector; $class_selector = 'graph';
	22					41
794							}
795
796	138					829	my @classes = $self->_check_class($class_selector);
797
798	138	50				448	return $self->error ("Illegal class '$class_selector' when trying to set attributes")
799							if @classes == 0;
800
801	138					579	foreach my $a (sort keys %$att)
802							{
803	156					459	for my $class (@classes)
804							{
805	164					768	$self->set_attribute($class, $a, $att->{$a});
806							}
807							}
808	138					464	$self;
809							}
810
811							sub del_attribute
812							{
813							# delete the attribute with the name in the selected class(es)
814	197			197	1	14323	my ($self, $class_selector, $name) = @_;
815
816	197	100				503	if (@_ == 2)
817							{
818	1					2	$name = $class_selector; $class_selector = 'graph';
	1					2
819							}
820
821							# font-size => fontsize
822	197	100				826	$name = $att_aliases->{$name} if exists $att_aliases->{$name};
823
824	197					477	my @classes = $self->_check_class($class_selector);
825
826	197	50				2120	return $self->error ("Illegal class '$class_selector' when trying to delete attribute '$name'")
827							if @classes == 0;
828
829	197					403	for my $class (@classes)
830							{
831	197					479	my $a = $self->{att}->{$class};
832
833	197					5358	delete $a->{$name};
834	197	50				584	if ($name eq 'size')
835							{
836	0					0	delete $a->{rows};
837	0					0	delete $a->{columns};
838							}
839	197	50				1056	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					577	$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	809	my ($self) = @_;
871
872	279					1082	my $flow = $self->{att}->{graph}->{flow};
873
874	279	100				1341	return 90 unless defined $flow;
875
876	86	100				634	my $f = $p_flow->{$flow}; $f = $flow unless defined $f;
	86					225
877	86					266	$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	11	my $self = shift;
889
890	4	50				20	$self->{output_format} = shift if $_[0];
891	4					25	$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	15	my $self = shift;
899
900	49			49		610	no strict 'refs';
	49					123
	49					431293
901
902	5					21	my $method = 'as_' . $self->{output_format};
903
904	5	50				36	$self->_croak("Cannot find a method to generate '$self->{output_format}'")
905							unless $self->can($method);
906
907	5					30	$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		55	my ($self, $skip, $map, $base, $indent, $overlay) = @_;
922
923	20					47	my $a = $self->{att};
924
925	20	50				69	$indent = '' unless defined $indent;
926	20	50				63	my $indent2 = $indent x 2; $indent2 = ' ' if $indent2 eq '';
	20					1047
927
928	20					113	my $class_list = { edge => {}, node => {}, group => {} };
929	20	50				74	if (defined $overlay)
930							{
931	20					43	$a = {};
932
933							# make a copy from $self->{att} to $a:
934
935	20					35	for my $class (sort keys %{$self->{att}})
	20					135
936							{
937	47					98	my $ac = $self->{att}->{$class};
938	47					106	$a->{$class} = {};
939	47					70	my $acc = $a->{$class};
940	47					161	for my $k (sort keys %$ac)
941							{
942	40					136	$acc->{$k} = $ac->{$k};
943							}
944							}
945
946							# add the extra keys
947	20					117	for my $class (sort keys %$overlay)
948							{
949	120					190	my $oc = $overlay->{$class};
950							# create the hash if it doesn't exist yet
951	120	100				302	$a->{$class} = {} unless ref $a->{$class};
952	120					177	my $acc = $a->{$class};
953	120					459	for my $k (sort keys %$oc)
954							{
955	540	50				1790	$acc->{$k} = $oc->{$k} unless exists $acc->{$k};
956							}
957	120					355	$class_list->{$class} = {};
958							}
959							}
960
961	20					60	my $id = $self->{id};
962
963	20					192	my @primaries = sort keys %$class_list;
964	20					50	foreach my $primary (@primaries)
965							{
966	120					190	my $cl = $class_list->{$primary}; # shortcut
967	120					450	foreach my $class (sort keys %$a)
968							{
969	738	100				3815	if ($class =~ /^$primary\.(.*)/)
970							{
971	43					193	$cl->{$1} = undef; # note w/o doubles
972							}
973							}
974							}
975
976	20	50				77	$base = "table.graph$id " unless defined $base;
977
978	20					97	my $groups = $self->groups(); # do we have groups?
979
980	20					50	my $css = '';
981	20					96	foreach my $class (sort keys %$a)
982							{
983	123	50				626	next if (not %{$a->{$class}}); # skip empty ones
	123					532
984
985	123					198	my $c = $class; $c =~ s/\./_/g; # node.city => node_city
	123					269
986
987	123	100	100			348	next if $class eq 'group' and $groups == 0;
988
989	107					137	my $css_txt = '';
990	107					140	my $cls = '';
991	107	50	66			403	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					43	$css_txt .= "$indent$base\{\n";
998							}
999							else
1000							{
1001	87	50				219	if ($c !~ /\./) # one of our primary ones
1002							{
1003							# generate also class list # like: "cities,node_rivers"
1004	87					180	$cls = join (",$base.${c}_", sort keys %{ $class_list->{$c} });
	87					372
1005	87	100				245	$cls = ",$base.${c}_$cls" if $cls ne ''; # like: ",node_cities,node_rivers"
1006							}
1007	87					198	$css_txt .= "$indent$base.$c$cls {\n";
1008							}
1009	107					168	my $done = 0;
1010	107					129	foreach my $att (sort keys %{$a->{$class}})
	107					528
1011							{
1012							# should be skipped?
1013	484	100	100			3993	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			1428	next if $class eq 'graph' && $base ne '' && $att =~ /^(color\|font\|fontsize\|align\|fill)\z/;
			100
1018
1019	432					652	$done++; # how many did we really?
1020	432					890	my $val = $a->{$class}->{$att};
1021
1022	432	50				810	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			1170	$val = 'none' if $att eq 'borderstyle' && $class eq 'group';
1027							# fix border-widths to be in pixel
1028	432	100	100			1246	$val .= 'px' if $att eq 'borderwidth' && $val !~ /(px\|em\|%)\z/;
1029
1030							# for color attributes, convert to hex
1031	432					1228	my $entry = $self->_attribute_entry($class, $att);
1032
1033	432	100				948	if (defined $entry)
1034							{
1035	228		100			684	my $type = $entry->[ ATTR_TYPE_SLOT ] \|\| ATTR_STRING;
1036	228	100				485	if ($type == ATTR_COLOR)
1037							{
1038							# create as RGB color
1039	92		66			290	$val = $self->get_color_attribute($class,$att) \|\| $val;
1040							}
1041							}
1042							# change attribute name/value?
1043	432	100				981	if (exists $map->{$att})
1044							{
1045	181	100				458	$att = $map->{$att} unless ref $map->{$att}; # change attribute name?
1046	181	100				490	($att,$val) = &{$map->{$att}}($self,$att,$val,$class) if ref $map->{$att};
	25					86
1047							}
1048
1049							# value is "inherit"?
1050	432	100	66			3552	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				48	my $base_class = $class; $base_class = 'graph' unless $base_class =~ /\./;
	32					107
1056	32					135	$base_class =~ s/\..*//;
1057
1058	32					71	$val = $a->{$base_class}->{$att};
1059
1060	32	50	33			148	if ($base_class ne 'graph' && (!defined $val \|\| $val eq 'inherit'))
			33
1061							{
1062							# node.foo => node, inherit => graph
1063	32					67	$val = $a->{graph}->{$att};
1064	32	50				93	$att = undef if !defined $val;
1065							}
1066							}
1067
1068	432	100	66			2337	$css_txt .= "$indent2$att: $val;\n" if defined $att && defined $val;
1069							}
1070
1071	107					237	$css_txt .= "$indent}\n";
1072	107	50				343	$css .= $css_txt if $done > 0; # skip if no attributes at all
1073							}
1074	20					2057	$css;
1075							}
1076
1077							sub _skip
1078							{
1079							# return a regexp that specifies which attributes to suppress in CSS
1080	20			20		39	my ($self) = shift;
1081
1082							# skip these for CSS
1083	20					352	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		3	my ($self,$name,$style) = @_;
1092
1093	1	50				15	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		54	my ($self,$name,$color,$class) = @_;
1102
1103	25	50				266	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	70	my $self = shift;
1114
1115	20					50	my $a = $self->{att};
1116	20					49	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					140	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					141	my @groups = $self->groups();
1139
1140							# Set attributes for all TDs that start with "group":
1141	20	100				75	$css .= <
1142							table.graph##id## td[class\|="group"] { padding: 0.2em; }
1143							CSS
1144							if @groups > 0;
1145
1146	20					57	$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	20					144	$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				27	if keys %{$self->{edges}} > 0;
1207
1208							# if we have nodes with rounded shapes:
1209	20					34	my $rounded = 0;
1210	20					199	for my $n (ord_values ( $self->{nodes} ))
1211							{
1212	56	100	100			228	$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				90	if $rounded > 0;
1221
1222							# append CSS for group cells (only if we actually have groups)
1223
1224	20	100				58	if (@groups > 0)
1225							{
1226	4					11	foreach my $group (@groups)
1227							{
1228	4					31	my $class = $group->class();
1229
1230	4					21	my $border = $group->attribute('borderstyle');
1231
1232	4					12	$class =~ s/.*\.//; # leave only subclass
1233	4					45	$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					663	$css =~ s/##id##/$id/g;
1239
1240	20					140	$css;
1241							}
1242
1243							sub html_page_header
1244							{
1245							# return the HTML header for as_html_file()
1246	10			10	1	25	my ($self, $css) = @_;
1247
1248	10					26	my $html = <
1249
1250
1251
1252
1253							##title####CSS##
1254
1255
1256							HTML
1257							;
1258
1259	10					74	$html =~ s/\n\z//;
1260	10					62	$html =~ s/##charset##/utf-8/g;
1261	10					38	my $t = $self->title();
1262	10					47	$html =~ s/##title##/$t/g;
1263
1264							# insert CSS if requested
1265	10	50				59	$css = $self->css() unless defined $css;
1266
1267	10	50				153	$html =~ s/##CSS##/\n