File Coverage

572						\|
573						<[^>]*> # or something like < a >
574						\|
575						[^<][^,\]\}\n\s;]* # or simple 'fooobar'
576						)
577						[,\]\n\}\s;]?\s*/x; # possible ",", "\n" etc.
578						}
579
580						sub _match_special_attribute
581						{
582						# match boolean attributes, these can appear without a value
583	638			638	1059	qr/\s*(
584						center\|
585						compound\|
586						concentrate\|
587						constraint\|
588						decorate\|
589						diredgeconstraints\|
590						fixedsize\|
591						headclip\|
592						labelfloat\|
593						landscape\|
594						mosek\|
595						nojustify\|
596						normalize\|
597						overlap\|
598						pack\|
599						pin\|
600						regular\|
601						remincross\|
602						root\|
603						splines\|
604						tailclip\|
605						truecolor
606						)[,;\s]?\s*/x;
607						}
608
609						sub _match_attributes
610						{
611						# return a regexp that matches something like " [ color=red; ]" and returns
612						# the inner text without the []
613
614	102			102	110	my $qr_att = _match_single_attribute();
615	102				128	my $qr_satt = _match_special_attribute();
616	102				126	my $qr_cmt = _match_multi_line_comment();
617
618	102				922	qr/\s\[\s((?:$qr_att\|$qr_satt\|$qr_cmt))\s\];?/;
619						}
620
621						sub _match_graph_attribute
622						{
623						# return a regexp that matches something like " color=red; " for attributes
624						# that apply to a graph/subgraph
625	102			102	146	qr/^\s(\w+\s=\s("[^"]+"\|[^;\n\s]+))([;\n\s]\s\|\z)/;
626						}
627
628						sub _match_optional_attributes
629						{
630						# return a regexp that matches something like " [ color=red; ]" and returns
631						# the inner text with the []
632
633	115			115	131	my $qr_att = _match_single_attribute();
634	115				143	my $qr_satt = _match_special_attribute();
635	115				132	my $qr_cmt = _match_multi_line_comment();
636
637	115				1150	qr/\s(\[\s((?:$qr_att\|$qr_satt\|$qr_cmt))\s\])?;?/;
638						}
639
640						sub _clean_attributes
641						{
642	370			370	345	my ($self,$text) = @_;
643
644	370				516	$text =~ s/^\s\[\s//; # remove left-over "[" and spaces
645	370				544	$text =~ s/\s;?\s\]\s*\z//; # remove left-over "]" and spaces
646
647	370				543	$text;
648						}
649
650						#############################################################################
651
652						sub _new_scope
653						{
654						# create a new scope, with attributes from current scope
655	121			121	127	my ($self, $is_group) = @_;
656
657	121				128	my $scope = {};
658
659	121	100			94	if (@{$self->{scope_stack}} > 0)
	121				228
660						{
661	19				28	my $old_scope = $self->{scope_stack}->[-1];
662
663						# make a copy of the old scope's attributes
664	19				47	for my $t (sort keys %$old_scope)
665						{
666	24	100			68	next if $t =~ /^_/;
667	5				5	my $s = $old_scope->{$t};
668	5	50			15	$scope->{$t} = {} unless ref $scope->{$t}; my $sc = $scope->{$t};
	5				6
669	5				10	for my $k (sort keys %$s)
670						{
671						# skip things like "_is_group"
672	7	50			21	$sc->{$k} = $s->{$k} unless $k =~ /^_/;
673						}
674						}
675						}
676	121	100			254	$scope->{_is_group} = 1 if defined $is_group;
677
678	121				92	push @{$self->{scope_stack}}, $scope;
	121				178
679	121				102	$scope;
680						}
681
682						sub _add_group_match
683						{
684						# register handlers for group start/end
685	102			102	90	my $self = shift;
686
687	102				146	my $qr_pseudo_group_start = $self->_match_pseudo_group_start_at_beginning();
688	102				154	my $qr_group_start = $self->_match_group_start();
689	102				144	my $qr_group_end = $self->_match_group_end();
690	102				116	my $qr_edge = $self->_match_edge();
691	102				127	my $qr_ocmt = $self->_match_optional_multi_line_comment();
692
693						# "subgraph G {"
694						$self->_register_handler( $qr_group_start,
695						sub
696						{
697	7			7	11	my $self = shift;
698	7				7	my $graph = $self->{_graph};
699	7				15	my $gn = $self->_unquote($1);
700	7	50			18	print STDERR "# Parser: found subcluster '$gn'\n" if $self->{debug};
701	7				6	push @{$self->{group_stack}}, $self->_new_group($gn);
	7				25
702	7				11	$self->_new_scope( 1 );
703	7				10	1;
704	102				317	} );
705
706						# "{ "
707						$self->_register_handler( $qr_pseudo_group_start,
708						sub
709						{
710	6			6	6	my $self = shift;
711	6	50			15	print STDERR "# Parser: Creating new scope\n" if $self->{debug};
712	6				13	$self->_new_scope();
713						# forget the left side
714	6				7	$self->{left_edge} = undef;
715	6				10	$self->{left_stack} = [ ];
716	6				10	1;
717	102				256	} );
718
719						# "} -> " group/cluster/scope end with an edge
720						$self->_register_handler( qr/$qr_group_end$qr_ocmt$qr_edge/,
721						sub
722						{
723	5			5	7	my $self = shift;
724
725	5				4	my $scope = pop @{$self->{scope_stack}};
	5				9
726	5	50			10	return $self->parse_error(0) if !defined $scope;
727
728	5	50	33		12	if ($scope->{_is_group} && @{$self->{group_stack}})
	0				0
729						{
730	0	0			0	print STDERR "# Parser: end subcluster '$self->{group_stack}->[-1]->{name}'\n" if $self->{debug};
731	0				0	pop @{$self->{group_stack}};
	0				0
732						}
733	5	50			10	else { print STDERR "# Parser: end scope\n" if $self->{debug}; }
734
735	5				8	1;
736						},
737						sub
738						{
739	5			5	7	my ($self, $line) = @_;
740	5				58	$line =~ qr/$qr_group_end$qr_edge/;
741	5				17	$1 . ' ';
742	102				658	} );
743
744						# "}" group/cluster/scope end
745						$self->_register_handler( $qr_group_end,
746						sub
747						{
748	116			116	95	my $self = shift;
749
750	116				79	my $scope = pop @{$self->{scope_stack}};
	116				153
751	116	50			184	return $self->parse_error(0) if !defined $scope;
752
753	116	100	100		207	if ($scope->{_is_group} && @{$self->{group_stack}})
	109				302
754						{
755	7	50			13	print STDERR "# Parser: end subcluster '$self->{group_stack}->[-1]->{name}'\n" if $self->{debug};
756	7				5	pop @{$self->{group_stack}};
	7				8
757						}
758						# always reset the stack
759	116				132	$self->{stack} = [ ];
760	116				239	1;
761	102				297	} );
762						}
763
764						sub _edge_style
765						{
766						# To convert "--" or "->" we simple do nothing, since the edge style in
767						# Graphviz can only be set via the attribute "style"
768	118			118	99	my ($self, $ed) = @_;
769
770	118				137	'solid';
771						}
772
773						sub _new_nodes
774						{
775	328			328	445	my ($self, $name, $group_stack, $att, $port, $stack) = @_;
776
777	328	100			503	$port = '' unless defined $port;
778	328				334	my @rc = ();
779						# "name1" => "name1"
780	328	100			493	if ($port ne '')
781						{
782						# create a special node
783	21				39	$name =~ s/^"//; $name =~ s/"\z//;
	21				37
784	21				26	$port =~ s/^"//; $port =~ s/"\z//;
	21				25
785						# XXX TODO: find unique name?
786	21				66	@rc = $self->_new_node ($self->{_graph}, "$name:$port", $group_stack, $att, $stack);
787	21				24	my $node = $rc[0];
788	21				25	$node->{_graphviz_portlet} = $port;
789	21				32	$node->{_graphviz_basename} = $name;
790						}
791						else
792						{
793	307				671	@rc = $self->_new_node ($self->{_graph}, $name, $group_stack, $att, $stack);
794						}
795	328				573	@rc;
796						}
797
798						sub _build_match_stack
799						{
800	102			102	93	my $self = shift;
801
802	102				160	my $qr_node = $self->_match_node();
803	102				145	my $qr_name = $self->_match_name();
804	102				139	my $qr_cmt = $self->_match_multi_line_comment();
805	102				153	my $qr_ocmt = $self->_match_optional_multi_line_comment();
806	102				153	my $qr_attr = $self->_match_attributes();
807	102				154	my $qr_gatr = $self->_match_graph_attribute();
808	102				148	my $qr_oatr = $self->_match_optional_attributes();
809	102				169	my $qr_edge = $self->_match_edge();
810	102				141	my $qr_pgr = $self->_match_pseudo_group_start();
811
812						# remove multi line comments /* comment */
813	102				426	$self->_register_handler( qr/^$qr_cmt/, undef );
814
815						# remove single line comment // comment
816	102				205	$self->_register_handler( qr/^\s\/\/./, undef );
817
818						# simple remove the graph start, but remember that we did this
819						$self->_register_handler( qr/^\s*((?i)strict)?$qr_ocmt((?i)digraph\|graph)$qr_ocmt$qr_node$qr_ocmt\{/,
820						sub
821						{
822	97			97	94	my $self = shift;
823	97	50			85	return $self->parse_error(6) if @{$self->{scope_stack}} > 0;
	97				220
824	97				198	$self->{_graphviz_graph_name} = $3;
825	97				170	$self->_new_scope(1);
826	97	100			295	$self->{_graph}->set_attribute('type','undirected') if lc($2) eq 'graph';
827	97				122	1;
828	102				1354	} );
829
830						# simple remove the graph start, but remember that we did this
831						$self->_register_handler( qr/^\s*(strict)?$qr_ocmt((?:di)?)graph$qr_ocmt\{/i,
832						sub
833						{
834	5			5	6	my $self = shift;
835	5	50			5	return $self->parse_error(6) if @{$self->{scope_stack}} > 0;
	5				12
836	5				8	$self->{_graphviz_graph_name} = 'unnamed';
837	5				11	$self->_new_scope(1);
838	5	100			21	$self->{_graph}->set_attribute('type','undirected') if lc($2) ne 'di';
839	5				7	1;
840	102				585	} );
841
842						# end-of-statement
843	102				215	$self->_register_handler( qr/^\s*;/, undef );
844
845						# cluster/subgraph "subgraph G { .. }"
846						# scope (dummy group): "{ .. }"
847						# scope/group/subgraph end: "}"
848	102				159	$self->_add_group_match();
849
850						# node [ color="red" ] etc.
851						# The "(?i)" makes the keywords match case-insensitive.
852						$self->_register_handler( qr/^\s*((?i)node\|graph\|edge)$qr_ocmt$qr_attr/,
853						sub
854						{
855	39			39	36	my $self = shift;
856	39		50		120	my $type = lc($1 \|\| '');
857	39		100		141	my $att = $self->_parse_attributes($2 \|\| '', $type, NO_MULTIPLES );
858	39	50			61	return undef unless defined $att; # error in attributes?
859
860	39	100			60	if ($type ne 'graph')
861						{
862						# apply the attributes to the current scope
863	25				29	my $scope = $self->{scope_stack}->[-1];
864	25	100			61	$scope->{$type} = {} unless ref $scope->{$type};
865	25				26	my $s = $scope->{$type};
866	25				57	for my $k (sort keys %$att)
867						{
868	27				45	$s->{$k} = $att->{$k};
869						}
870						}
871						else
872						{
873	14				17	my $graph = $self->{_graph};
874	14				35	$graph->set_attributes ($type, $att);
875						}
876
877						# forget stacks
878	39				51	$self->{stack} = [];
879	39				44	$self->{left_edge} = undef;
880	39				38	$self->{left_stack} = [];
881	39				70	1;
882	102				1068	} );
883
884						# color=red; (for graphs or subgraphs)
885	102				199	$self->_register_attribute_handler($qr_gatr, 'parent');
886						# [ color=red; ] (for nodes/edges)
887	102				229	$self->_register_attribute_handler($qr_attr);
888
889						# node chain continued like "-> { ... "
890						$self->_register_handler( qr/^$qr_edge$qr_ocmt$qr_pgr/,
891						sub
892						{
893	6			6	8	my $self = shift;
894
895	6	50			5	return if @{$self->{stack}} == 0; # only match this if stack non-empty
	6				16
896
897	6				6	my $graph = $self->{_graph};
898	6				9	my $eg = $1; # entire edge ("->" etc)
899
900	6	100			6	my $edge_un = 0; $edge_un = 1 if $eg eq '--'; # undirected edge?
	6				10
901
902						# need to defer edge attribute parsing until the edge exists
903						# if inside a scope, set the scope attributes, too:
904	6		50		16	my $scope = $self->{scope_stack}->[-1] \|\| {};
905	6		50		21	my $edge_atr = $scope->{edge} \|\| {};
906
907						# create a new scope
908	6				11	$self->_new_scope();
909
910						# remember the left side
911	6				13	$self->{left_edge} = [ 'solid', '', $edge_atr, 0, $edge_un ];
912	6				9	$self->{left_stack} = $self->{stack};
913
914						# forget stack and remember the right side instead
915	6				6	$self->{stack} = [];
916
917	6				10	1;
918	102				729	} );
919
920						# "Berlin"
921						$self->_register_handler( qr/^$qr_node/,
922						sub
923						{
924	210			210	184	my $self = shift;
925	210				172	my $graph = $self->{_graph};
926
927						# only match this inside a "{ }" (normal, non-group) scope
928	210	100			513	return if exists $self->{scope_stack}->[-1]->{_is_group};
929
930	31				52	my $n1 = $1;
931	31				32	my $port = $2;
932	31				80	push @{$self->{stack}},
933	31				24	$self->_new_nodes ($n1, $self->{group_stack}, {}, $port, $self->{stack});
934
935	31	100			69	if (defined $self->{left_edge})
936						{
937	15				18	my $e = $self->{use_class}->{edge};
938	15				12	my ($style, $edge_label, $edge_atr, $edge_bd, $edge_un) = @{$self->{left_edge}};
	15				25
939
940	15				9	foreach my $node (@{$self->{left_stack}})
	15				21
941						{
942	15				55	my $edge = $e->new( { style => $style, name => $edge_label } );
943
944						# if inside a scope, set the scope attributes, too:
945	15				26	my $scope = $self->{scope_stack}->[-1];
946	15	50			52	$edge->set_attributes($scope->{edge}) if $scope;
947
948						# override with the local attributes
949						# 'string' => [ 'string' ]
950						# [ { hash }, 'string' ] => [ { hash }, 'string' ]
951	15	50			17	my $e = $edge_atr; $e = [ $edge_atr ] unless ref($e) eq 'ARRAY';
	15				32
952
953	15				16	for my $a (@$e)
954						{
955	15	50			21	if (ref $a)
956						{
957	15				25	$edge->set_attributes($a);
958						}
959						else
960						{
961						# deferred parsing with the object as param:
962	0				0	my $out = $self->_parse_attributes($a, $edge, NO_MULTIPLES);
963	0	0			0	return undef unless defined $out; # error in attributes?
964	0				0	$edge->set_attributes($out);
965						}
966						}
967
968						# "<--->": bidirectional
969	15	50			22	$edge->bidirectional(1) if $edge_bd;
970	15	100			26	$edge->undirected(1) if $edge_un;
971	15				36	$graph->add_edge ( $node, $self->{stack}->[-1], $edge );
972						}
973						}
974	31				47	1;
975	102				1013	} );
976
977						# "Berlin" [ color=red ] or "Bonn":"a" [ color=red ]
978						$self->_register_handler( qr/^$qr_node$qr_oatr/,
979						sub
980						{
981	179			179	151	my $self = shift;
982	179				246	my $name = $1;
983	179				173	my $port = $2;
984	179	50	50		566	my $compass = $4 \|\| ''; $port .= ":$compass" if $compass;
	179				239
985
986	179				410	$self->{stack} = [ $self->_new_nodes ($name, $self->{group_stack}, {}, $port ) ];
987
988						# defer attribute parsing until object exists
989	179				289	my $node = $self->{stack}->[0];
990	179		100		841	my $a1 = $self->_parse_attributes($5\|\|'', $node);
991	179	50			315	return undef if $self->{error};
992	179				290	$node->set_attributes($a1);
993
994						# forget left stack
995	179				160	$self->{left_edge} = undef;
996	179				263	$self->{left_stack} = [];
997	179				329	1;
998	102				1462	} );
999
1000						# Things like ' "Node" ' will be consumed before, so we do not need a case
1001						# for '"Bonn" -> "Berlin"'
1002
1003						# node chain continued like "-> "Kassel" [ ... ]"
1004						$self->_register_handler( qr/^$qr_edge$qr_ocmt$qr_node$qr_ocmt$qr_oatr/,
1005						sub
1006						{
1007	118			118	102	my $self = shift;
1008
1009	118	50			86	return if @{$self->{stack}} == 0; # only match this if stack non-empty
	118				227
1010
1011	118				108	my $graph = $self->{_graph};
1012	118				167	my $eg = $1; # entire edge ("->" etc)
1013	118				116	my $n = $2; # node name
1014	118				106	my $port = $3;
1015	118	100	50		519	my $compass = $4 \|\| $5 \|\| ''; $port .= ":$compass" if $compass;
	118				144
1016
1017	118	100			96	my $edge_un = 0; $edge_un = 1 if $eg eq '--'; # undirected edge?
	118				155
1018
1019	118		50		210	my $scope = $self->{scope_stack}->[-1] \|\| {};
1020
1021						# need to defer edge attribute parsing until the edge exists
1022	118		100		600	my $edge_atr = [ $6\|\|'', $scope->{edge} \|\| {} ];
			100
1023
1024						# the right side nodes:
1025	118				254	my $nodes_b = [ $self->_new_nodes ($n, $self->{group_stack}, {}, $port) ];
1026
1027	118				309	my $style = $self->_link_lists( $self->{stack}, $nodes_b,
1028						'--', '', $edge_atr, 0, $edge_un);
1029
1030						# remember the left side
1031	118				223	$self->{left_edge} = [ $style, '', $edge_atr, 0, $edge_un ];
1032	118				139	$self->{left_stack} = $self->{stack};
1033
1034						# forget stack and remember the right side instead
1035	118				108	$self->{stack} = $nodes_b;
1036	118				176	1;
1037	102				1596	} );
1038
1039	102				391	$self;
1040						}
1041
1042						sub _add_node
1043						{
1044						# add a node to the graph, overridable by subclasses
1045	321			321	306	my ($self, $graph, $name) = @_;
1046
1047						# "a -- clusterB" should not create a spurious node named "clusterB"
1048	321				632	my @groups = $graph->groups();
1049	321				490	for my $g (@groups)
1050						{
1051	40	50			70	return $g if $g->{name} eq $name;
1052						}
1053
1054	321				513	my $node = $graph->node($name);
1055
1056	321	100			505	if (!defined $node)
1057						{
1058	252				390	$node = $graph->add_node($name); # add
1059
1060						# apply attributes from the current scope (only for new nodes)
1061	252				321	my $scope = $self->{scope_stack}->[-1];
1062	252	50			391	return $self->error("Scope stack is empty!") unless defined $scope;
1063
1064	252				222	my $is_group = $scope->{_is_group};
1065	252				265	delete $scope->{_is_group};
1066	252				627	$node->set_attributes($scope->{node});
1067	252	100			585	$scope->{_is_group} = $is_group if $is_group;
1068						}
1069
1070	321				612	$node;
1071						}
1072
1073						#############################################################################
1074						# attribute remapping
1075
1076						# undef => drop that attribute
1077						# not listed attributes will result in "x-dot-$attribute" and a warning
1078
1079						my $remap = {
1080						'node' => {
1081						'distortion' => 'x-dot-distortion',
1082
1083						'fixedsize' => undef,
1084						'group' => 'x-dot-group',
1085						'height' => 'x-dot-height',
1086
1087						# XXX TODO: ignore non-node attributes set in a scope
1088						'dir' => undef,
1089
1090						'layer' => 'x-dot-layer',
1091						'margin' => 'x-dot-margin',
1092						'orientation' => \&_from_graphviz_node_orientation,
1093						'peripheries' => \&_from_graphviz_node_peripheries,
1094						'pin' => 'x-dot-pin',
1095						'pos' => 'x-dot-pos',
1096						# XXX TODO: rank=0 should make that node the root node
1097						# 'rank' => undef,
1098						'rects' => 'x-dot-rects',
1099						'regular' => 'x-dot-regular',
1100						# 'root' => undef,
1101						'sides' => 'x-dot-sides',
1102						'shapefile' => 'x-dot-shapefile',
1103						'shape' => \&_from_graphviz_node_shape,
1104						'skew' => 'x-dot-skew',
1105						'style' => \&_from_graphviz_style,
1106						'width' => 'x-dot-width',
1107						'z' => 'x-dot-z',
1108						},
1109
1110						'edge' => {
1111						'arrowsize' => 'x-dot-arrowsize',
1112						'arrowhead' => \&_from_graphviz_arrow_style,
1113						'arrowtail' => 'x-dot-arrowtail',
1114						# important for color lists like "red:red" => double edge
1115						'color' => \&_from_graphviz_edge_color,
1116						'constraint' => 'x-dot-constraint',
1117						'dir' => \&_from_graphviz_edge_dir,
1118						'decorate' => 'x-dot-decorate',
1119						'f' => 'x-dot-f',
1120						'headclip' => 'x-dot-headclip',
1121						'headhref' => 'headlink',
1122						'headurl' => 'headlink',
1123						'headport' => \&_from_graphviz_headport,
1124						'headlabel' => 'headlabel',
1125						'headtarget' => 'x-dot-headtarget',
1126						'headtooltip' => 'headtitle',
1127						'labelangle' => 'x-dot-labelangle',
1128						'labeldistance' => 'x-dot-labeldistance',
1129						'labelfloat' => 'x-dot-labelfloat',
1130						'labelfontcolor' => \&_from_graphviz_color,
1131						'labelfontname' => 'font',
1132						'labelfontsize' => 'font-size',
1133						'layer' => 'x-dot-layer',
1134						'len' => 'x-dot-len',
1135						'lhead' => 'x-dot-lhead',
1136						'ltail' => 'x-dot-tail',
1137						'minlen' => \&_from_graphviz_edge_minlen,
1138						'pos' => 'x-dot-pos',
1139						'samehead' => 'x-dot-samehead',
1140						'samearrowhead' => 'x-dot-samearrowhead',
1141						'sametail' => 'x-dot-sametail',
1142						'style' => \&_from_graphviz_edge_style,
1143						'tailclip' => 'x-dot-tailclip',
1144						'tailhref' => 'taillink',
1145						'tailurl' => 'taillink',
1146						'tailport' => \&_from_graphviz_tailport,
1147						'taillabel' => 'taillabel',
1148						'tailtarget' => 'x-dot-tailtarget',
1149						'tailtooltip' => 'tailtitle',
1150						'weight' => 'x-dot-weight',
1151						},
1152
1153						'graph' => {
1154						'damping' => 'x-dot-damping',
1155						'K' => 'x-dot-k',
1156						'bb' => 'x-dot-bb',
1157						'center' => 'x-dot-center',
1158						# will be handled automatically:
1159						'charset' => undef,
1160						'clusterrank' => 'x-dot-clusterrank',
1161						'compound' => 'x-dot-compound',
1162						'concentrate' => 'x-dot-concentrate',
1163						'defaultdist' => 'x-dot-defaultdist',
1164						'dim' => 'x-dot-dim',
1165						'dpi' => 'x-dot-dpi',
1166						'epsilon' => 'x-dot-epsilon',
1167						'esep' => 'x-dot-esep',
1168						'fontpath' => 'x-dot-fontpath',
1169						'labeljust' => \&_from_graphviz_graph_labeljust,
1170						'labelloc' => \&_from_graphviz_labelloc,
1171						'landscape' => 'x-dot-landscape',
1172						'layers' => 'x-dot-layers',
1173						'layersep' => 'x-dot-layersep',
1174						'levelsgap' => 'x-dot-levelsgap',
1175						'margin' => 'x-dot-margin',
1176						'maxiter' => 'x-dot-maxiter',
1177						'mclimit' => 'x-dot-mclimit',
1178						'mindist' => 'x-dot-mindist',
1179						'minquit' => 'x-dot-minquit',
1180						'mode' => 'x-dot-mode',
1181						'model' => 'x-dot-model',
1182						'nodesep' => 'x-dot-nodesep',
1183						'normalize' => 'x-dot-normalize',
1184						'nslimit' => 'x-dot-nslimit',
1185						'nslimit1' => 'x-dot-nslimit1',
1186						'ordering' => 'x-dot-ordering',
1187						'orientation' => 'x-dot-orientation',
1188						'output' => 'output',
1189						'outputorder' => 'x-dot-outputorder',
1190						'overlap' => 'x-dot-overlap',
1191						'pack' => 'x-dot-pack',
1192						'packmode' => 'x-dot-packmode',
1193						'page' => 'x-dot-page',
1194						'pagedir' => 'x-dot-pagedir',
1195						'pencolor' => \&_from_graphviz_color,
1196						'quantum' => 'x-dot-quantum',
1197						'rankdir' => \&_from_graphviz_graph_rankdir,
1198						'ranksep' => 'x-dot-ranksep',
1199						'ratio' => 'x-dot-ratio',
1200						'remincross' => 'x-dot-remincross',
1201						'resolution' => 'x-dot-resolution',
1202						'rotate' => 'x-dot-rotate',
1203						'samplepoints' => 'x-dot-samplepoints',
1204						'searchsize' => 'x-dot-searchsize',
1205						'sep' => 'x-dot-sep',
1206						'size' => 'x-dot-size',
1207						'splines' => 'x-dot-splines',
1208						'start' => 'x-dot-start',
1209						'style' => \&_from_graphviz_style,
1210						'stylesheet' => 'x-dot-stylesheet',
1211						'truecolor' => 'x-dot-truecolor',
1212						'viewport' => 'x-dot-viewport',
1213						'voro-margin' => 'x-dot-voro-margin',
1214						},
1215
1216						'group' => {
1217						'labeljust' => \&_from_graphviz_graph_labeljust,
1218						'labelloc' => \&_from_graphviz_labelloc,
1219						'pencolor' => \&_from_graphviz_color,
1220						'style' => \&_from_graphviz_style,
1221						'K' => 'x-dot-k',
1222						},
1223
1224						'all' => {
1225						'color' => \&_from_graphviz_color,
1226						'colorscheme' => 'x-colorscheme',
1227						'bgcolor' => \&_from_graphviz_color,
1228						'fillcolor' => \&_from_graphviz_color,
1229						'fontsize' => \&_from_graphviz_font_size,
1230						'fontcolor' => \&_from_graphviz_color,
1231						'fontname' => 'font',
1232						'lp' => 'x-dot-lp',
1233						'nojustify' => 'x-dot-nojustify',
1234						'rank' => 'x-dot-rank',
1235						'showboxes' => 'x-dot-showboxes',
1236						'target' => 'x-dot-target',
1237						'tooltip' => 'title',
1238						'URL' => 'link',
1239						'href' => 'link',
1240						},
1241						};
1242
1243	123			123	114	sub _remap { $remap; }
1244
1245						my $rankdir = {
1246						'LR' => 'east',
1247						'RL' => 'west',
1248						'TB' => 'south',
1249						'BT' => 'north',
1250						};
1251
1252						sub _from_graphviz_graph_rankdir
1253						{
1254	3			3	7	my ($self, $name, $dir, $object) = @_;
1255
1256	3		50		10	my $d = $rankdir->{$dir} \|\| 'east';
1257
1258	3				9	('flow', $d);
1259						}
1260
1261						my $shapes = {
1262						box => 'rect',
1263						polygon => 'rect',
1264						egg => 'rect',
1265						rectangle => 'rect',
1266						mdiamond => 'diamond',
1267						msquare => 'rect',
1268						plaintext => 'none',
1269						none => 'none',
1270						};
1271
1272						sub _from_graphviz_node_shape
1273						{
1274	19			19	28	my ($self, $name, $shape) = @_;
1275
1276	19				20	my @rc;
1277	19				30	my $s = lc($shape);
1278	19	100			52	if ($s =~ /^(triple\|double)/)
1279						{
1280	1				3	$s =~ s/^(triple\|double)//;
1281	1				3	push @rc, ('border-style','double');
1282						}
1283
1284						# map the name to what Graph::Easy expects (ellipse stays as ellipse f.i.)
1285	19		66		68	$s = $shapes->{$s} \|\| $s;
1286
1287	19				53	(@rc, $name, $s);
1288						}
1289
1290						sub _from_graphviz_style
1291						{
1292	10			10	15	my ($self, $name, $style, $class) = @_;
1293
1294	10				35	my @styles = split /\s,\s/, $style;
1295
1296	10				13	my $is_node = 0;
1297	10	100	100		68	$is_node = 1 if ref($class) && !$class->isa('Graph::Easy::Group');
1298	10	50	66		42	$is_node = 1 if !ref($class) && defined $class && $class eq 'node';
			66
1299
1300	10				9	my @rc;
1301	10				15	for my $s (@styles)
1302						{
1303	10	100			16	@rc = ('shape', 'rounded') if $s eq 'rounded';
1304	10	100			18	@rc = ('shape', 'invisible') if $s eq 'invis';
1305	10	100			34	@rc = ('border', 'black ' . $1) if $s =~ /^(bold\|dotted\|dashed)\z/;
1306	10	100			16	if ($is_node != 0)
1307						{
1308	8	100			19	@rc = ('shape', 'rect') if $s eq 'filled';
1309						}
1310						# convert "setlinewidth(12)" =>
1311	10	100			26	if ($s =~ /setlinewidth$(\d+\|\d*\.\d+)$/)
1312						{
1313	2		50		7	my $width = abs($1 \|\| 1);
1314	2				3	my $style = '';
1315	2				3	$style = 'wide'; # > 11
1316	2	50			3	$style = 'solid' if $width < 3;
1317	2	100	66		9	$style = 'bold' if $width >= 3 && $width < 5;
1318	2	100	66		8	$style = 'broad' if $width >= 5 && $width < 11;
1319	2				5	push @rc, ('borderstyle',$style);
1320						}
1321						}
1322
1323	10				28	@rc;
1324						}
1325
1326						sub _from_graphviz_node_orientation
1327						{
1328	0			0	0	my ($self, $name, $o) = @_;
1329
1330	0				0	my $r = int($o);
1331
1332	0	0			0	return (undef,undef) if $r == 0;
1333
1334						# 1.0 => 1
1335	0				0	('rotate', $r);
1336						}
1337
1338						my $port_remap = {
1339						n => 'north',
1340						e => 'east',
1341						w => 'west',
1342						s => 'south',
1343						};
1344
1345						sub _from_graphviz_headport
1346						{
1347	1			1	2	my ($self, $name, $compass) = @_;
1348
1349						# XXX TODO
1350						# handle "port:compass" too
1351
1352						# one of "n","ne","e","se","s","sw","w","nw
1353						# "ne => n"
1354	1		50		7	my $c = $port_remap->{ substr(lc($compass),0,1) } \|\| 'east';
1355
1356	1				4	('end', $c);
1357						}
1358
1359						sub _from_graphviz_tailport
1360						{
1361	1			1	3	my ($self, $name, $compass) = @_;
1362
1363						# XXX TODO
1364						# handle "port:compass" too
1365
1366						# one of "n","ne","e","se","s","sw","w","nw
1367						# "ne => n" => "north"
1368	1		50		8	my $c = $port_remap->{ substr(lc($compass),0,1) } \|\| 'east';
1369
1370	1				3	('start', $c);
1371						}
1372
1373						sub _from_graphviz_node_peripheries
1374						{
1375	0			0	0	my ($self, $name, $cnt) = @_;
1376
1377	0	0			0	return (undef,undef) if $cnt < 2;
1378
1379						# peripheries = 2 => double border
1380	0				0	('border-style', 'double');
1381						}
1382
1383						sub _from_graphviz_edge_minlen
1384						{
1385	0			0	0	my ($self, $name, $len) = @_;
1386
1387						# 1 => 1, 2 => 3, 3 => 5 etc
1388	0				0	$len = $len * 2 - 1;
1389	0				0	($name, $len);
1390						}
1391
1392						sub _from_graphviz_font_size
1393						{
1394	2			2	2	my ($self, $f, $size) = @_;
1395
1396						# 20 => 20px
1397	2	50			15	$size = $size . 'px' if $size =~ /^\d+(\.\d+)?\z/;
1398
1399	2				6	('fontsize', $size);
1400						}
1401
1402						sub _from_graphviz_labelloc
1403						{
1404	3			3	5	my ($self, $name, $loc) = @_;
1405
1406	3				4	my $l = 'top';
1407	3	50			12	$l = 'bottom' if $loc =~ /^b/;
1408
1409	3				7	('labelpos', $l);
1410						}
1411
1412						sub _from_graphviz_edge_dir
1413						{
1414	2			2	4	my ($self, $name, $dir, $edge) = @_;
1415
1416						# Modify the edge, depending on dir
1417	2	100			7	if (ref($edge))
1418						{
1419						# "forward" is the default and ignored
1420	1	50			7	$edge->flip() if $dir eq 'back';
1421	1	50			3	$edge->bidirectional(1) if $dir eq 'both';
1422	1	50			3	$edge->undirected(1) if $dir eq 'none';
1423						}
1424
1425	2				4	(undef, undef);
1426						}
1427
1428						sub _from_graphviz_edge_style
1429						{
1430	11			11	15	my ($self, $name, $style, $object) = @_;
1431
1432						# input: solid dashed dotted bold invis
1433	11	100			19	$style = 'invisible' if $style eq 'invis';
1434
1435						# although "normal" is not documented, it occurs in the wild
1436	11	50			17	$style = 'solid' if $style eq 'normal';
1437
1438						# convert "setlinewidth(12)" =>
1439	11	100			35	if ($style =~ /setlinewidth$(\d+\|\d*\.\d+)$/)
1440						{
1441	6		50		19	my $width = abs($1 \|\| 1);
1442	6				5	$style = 'wide'; # > 11
1443	6	100			11	$style = 'solid' if $width < 3;
1444	6	100	100		22	$style = 'bold' if $width >= 3 && $width < 5;
1445	6	100	100		18	$style = 'broad' if $width >= 5 && $width < 11;
1446						}
1447
1448	11				25	($name, $style);
1449						}
1450
1451						sub _from_graphviz_arrow_style
1452						{
1453	0			0	0	my ($self, $name, $shape, $object) = @_;
1454
1455	0				0	my $style = 'open';
1456
1457	0	0			0	$style = 'closed' if $shape =~ /^(empty\|onormal)\z/;
1458	0	0	0		0	$style = 'filled' if $shape eq 'normal' \|\| $shape eq 'normalnormal';
1459	0	0	0		0	$style = 'open' if $shape eq 'vee' \|\| $shape eq 'veevee';
1460	0	0	0		0	$style = 'none' if $shape eq 'none' \|\| $shape eq 'nonenone';
1461
1462	0				0	('arrow-style', $style);
1463						}
1464
1465						my $color_atr_map = {
1466						fontcolor => 'color',
1467						bgcolor => 'background',
1468						fillcolor => 'fill',
1469						pencolor => 'bordercolor',
1470						labelfontcolor => 'labelcolor',
1471						color => 'color',
1472						};
1473
1474						sub _from_graphviz_color
1475						{
1476						# Remap the color name and value
1477	31			31	390	my ($self, $name, $color) = @_;
1478
1479						# "//red" => "red"
1480	31				38	$color =~ s/^\/\///;
1481
1482	31				26	my $colorscheme = 'x11';
1483	31	100			58	if ($color =~ /^\//)
1484						{
1485						# "/set9/red" => "red"
1486	3				16	$color =~ s/^\/([^\/]+)\///;
1487	3				9	$colorscheme = $1;
1488						# map the color to the right color according to the colorscheme
1489	3		50		11	$color = Graph::Easy->color_value($color,$colorscheme) \|\| 'black';
1490						}
1491
1492						# "#AA BB CC => "#AABBCC"
1493	31	100			67	$color =~ s/\s+//g if $color =~ /^#/;
1494
1495						# "0.1 0.4 0.5" => "hsv(0.1,0.4,0.5)"
1496	31	100			73	$color =~ s/\s+/,/g if $color =~ /\s/;
1497	31	100			64	$color = 'hsv(' . $color . ')' if $color =~ /,/;
1498
1499	31				90	($color_atr_map->{$name}, $color);
1500						}
1501
1502						sub _from_graphviz_edge_color
1503						{
1504						# remap the color name and value
1505	10			10	12	my ($self, $name, $color) = @_;
1506
1507	10				25	my @colors = split /:/, $color;
1508
1509	10				13	for my $c (@colors)
1510						{
1511	10				13	$c = Graph::Easy::Parser::Graphviz::_from_graphviz_color($self,$name,$c);
1512						}
1513
1514	10				11	my @rc;
1515	10	50			15	if (@colors > 1)
1516						{
1517						# 'red:blue' => "style: double; color: red"
1518	0				0	push @rc, 'style', 'double';
1519						}
1520
1521	10				30	(@rc, $color_atr_map->{$name}, $colors[0]);
1522						}
1523
1524						sub _from_graphviz_graph_labeljust
1525						{
1526	4			4	7	my ($self, $name, $l) = @_;
1527
1528						# input: "l" "r" or "c", output "left", "right" or "center"
1529	4				6	my $a = 'center';
1530	4	100			10	$a = 'left' if $l eq 'l';
1531	4	100			7	$a = 'right' if $l eq 'r';
1532
1533	4				9	('align', $a);
1534						}
1535
1536						#############################################################################
1537
1538						sub _remap_attributes
1539						{
1540	183			183	222	my ($self, $att, $object, $r) = @_;
1541
1542	183	50			288	if ($self->{debug})
1543						{
1544	0	0			0	my $o = ''; $o = " for $object" if $object;
	0				0
1545	0				0	print STDERR "# remapping attributes '$att'$o\n";
1546	0				0	require Data::Dumper; print STDERR "#" , Data::Dumper::Dumper($att),"\n";
	0				0
1547						}
1548
1549	183	100			430	$r = $self->_remap() unless defined $r;
1550
1551	183				471	$self->{_graph}->_remap_attributes($object, $att, $r, 'noquote', undef, undef);
1552						}
1553
1554						#############################################################################
1555
1556						my $html_remap = {
1557						'table' => {
1558						'align' => 'align',
1559						'balign' => undef,
1560						'bgcolor' => 'fill',
1561						'border' => 'border',
1562						# XXX TODO
1563						'cellborder' => 'border',
1564						'cellspacing' => undef,
1565						'cellpadding' => undef,
1566						'fixedsize' => undef,
1567						'height' => undef,
1568						'href' => 'link',
1569						'port' => undef,
1570						'target' => undef,
1571						'title' => 'title',
1572						'tooltip' => 'title',
1573						'valign' => undef,
1574						'width' => undef,
1575						},
1576						'td' => {
1577						'align' => 'align',
1578						'balign' => undef,
1579						'bgcolor' => 'fill',
1580						'border' => 'border',
1581						'cellspacing' => undef,
1582						'cellpadding' => undef,
1583						'colspan' => 'columns',
1584						'fixedsize' => undef,
1585						'height' => undef,
1586						'href' => 'link',
1587						'port' => undef,
1588						'rowspan' => 'rows',
1589						'target' => undef,
1590						'title' => 'title',
1591						'tooltip' => 'title',
1592						'valign' => undef,
1593						'width' => undef,
1594						},
1595						};
1596
1597						sub _parse_html_attributes
1598						{
1599	5			5	9	my ($self, $text, $qr, $tag) = @_;
1600
1601						# "	" => " ..."
1602	5				28	$text =~ s/^$qr->{td_tag}//;
1603	5				12	$text =~ s/\s*>\z//;
1604
1605	5				7	my $attr = {};
1606	5				9	while ($text ne '')
1607						{
1608
1609	9	50			68	return $self->error("HTML-like attribute '$text' doesn't look valid to me.")
1610						unless $text =~ s/^($qr->{attribute})//;
1611
1612	9				14	my $name = lc($2); my $value = $3;
	9				10
1613
1614	9				12	$self->_unquote($value);
1615	9	100			15	$value = lc($value) if $name eq 'align';
1616	9	50			15	$self->error ("Unknown attribute '$name' in HTML-like label") unless exists $html_remap->{$tag}->{$name};
1617						# filter out attributes we do not yet support
1618	9	100			31	$attr->{$name} = $value if defined $html_remap->{$tag}->{$name};
1619						}
1620
1621	5				12	$attr;
1622						}
1623
1624						sub _html_per_table
1625						{
1626						# take the HTML-like attributes found per TABLE and create a hash with them
1627						# so they can be applied as default to each node
1628	0			0	0	my ($self, $attributes) = @_;
1629
1630	0				0	$self->_remap_attributes($attributes,'table',$html_remap);
1631						}
1632
1633						sub _html_per_node
1634						{
1635						# take the HTML-like attributes found per TD and apply them to the node
1636	3			3	5	my ($self, $attr, $node) = @_;
1637
1638	3		50		12	my $c = $attr->{colspan} \|\| 1;
1639	3	50			4	$node->set_attribute('columns',$c) if $c != 1;
1640
1641	3		50		8	my $r = $attr->{rowspan} \|\| 1;
1642	3	50			10	$node->set_attribute('rows',$r) if $r != 1;
1643
1644	3	50			6	$node->{autosplit_portname} = $attr->{port} if exists $attr->{port};
1645
1646	3				4	for my $k (qw/port colspan rowspan/)
1647						{
1648	9				8	delete $attr->{$k};
1649						}
1650
1651	3				6	my $att = $self->_remap_attributes($attr,$node,$html_remap);
1652
1653	3				7	$node->set_attributes($att);
1654
1655	3				5	$self;
1656						}
1657
1658						sub _parse_html
1659						{
1660						# Given an HTML label, parses that into the individual parts. Returns a
1661						# list of nodes.
1662	2			2	3	my ($self, $n, $qr) = @_;
1663
1664	2				3	my $graph = $self->{_graph};
1665
1666	2	50			6	my $label = $n->label(1); $label = '' unless defined $label;
	2				4
1667	2				2	my $org_label = $label;
1668
1669						# print STDERR "# 1 HTML-like label is now: $label\n";
1670
1671						# "unquote" the HTML-like label
1672	2				7	$label =~ s/^<\s*//;
1673	2				12	$label =~ s/\s*>\z//;
1674
1675						# print STDERR "# 2 HTML-like label is now: $label\n";
1676
1677						# remove the table end (at the end)
1678	2				35	$label =~ s/$qr->{table_end}\s*\z//;
1679						# print STDERR "# 2.a HTML-like label is now: $label\n";
1680						# remove the table start
1681	2				32	$label =~ s/($qr->{table})//;
1682
1683						# print STDERR "# 3 HTML-like label is now: $label\n";
1684
1685	2		50		8	my $table_tag = $1 \|\| '';
1686	2				16	$table_tag =~ /$qr->{table_tag}(.*?)>/;
1687	2		50		10	my $table_attr = $self->_parse_html_attributes($1 \|\| '', $qr, 'table');
1688
1689						# use Data::Dumper;
1690						# print STDERR "# 3 HTML-like table-tag attributes are: ", Dumper($table_attr),"\n";
1691
1692						# generate the base name from the actual graphviz node name to allow links to
1693						# it
1694	2				7	my $base_name = $n->{name};
1695
1696	2				1	my $class = $self->{use_class}->{node};
1697
1698	2				7	my $raw_attributes = $n->raw_attributes();
1699	2				2	delete $raw_attributes->{label};
1700	2				2	delete $raw_attributes->{shape};
1701
1702	2				3	my @rc; my $first_in_row;
1703	2				2	my $x = 0; my $y = 0; my $idx = 0;
	2				1
	2				2
1704	2				4	while ($label ne '')
1705						{
1706	3				41	$label =~ s/^\s*($qr->{row})//;
1707
1708	3	50			8	return $self->error ("Cannot parse HTML-like label: '$label'")
1709						unless defined $1;
1710
1711						# we now got one row:
1712	3				4	my $row = $1;
1713
1714						# print STDERR "# 3 HTML-like row is $row\n";
1715
1716						# remove
1717	3				18	$row =~ s/^\s$qr->{tr}\s//;
1718						# remove
1719	3				25	$row =~ s/\s$qr->{tr_end}\s\z//;
1720
1721	3				3	my $first = 1;
1722	3				7	while ($row ne '')
1723						{
1724						# remove one TD from the current row text
1725	3				28	$row =~ s/^($qr->{td})($qr->{text})$qr->{td_end}//;
1726	3	50			8	return $self->error ("Cannot parse HTML-like row: '$row'")
1727						unless defined $1;
1728
1729	3				4	my $node_label = $2;
1730	3				4	my $attr_txt = $1;
1731
1732						# convert " " etc. to line breaks
1733						# XXX TODO apply here the default of BALIGN
1734	3				6	$node_label =~ s//\\n/gi;
1735
1736						# if the font covers the entire node, set "font" attribute
1737	3				3	my $font_face = undef;
1738	3	50			6	if ($node_label =~ /^[ ](.)<\/FONT>[ ]*\z/i)
1739						{
1740	0				0	$node_label = $2; $font_face = $1;
	0				0
1741						}
1742						# XXX TODO if not, allow inline font changes
1743	3				4	$node_label =~ s/]+>(.*)<\/FONT>/$1/ig;
1744
1745	3				5	my $node_name = $base_name . '.' . $idx;
1746
1747						# if it doesn't exist, add it, otherwise retrieve node object to $node
1748
1749	3				8	my $node = $graph->node($node_name);
1750	3	50			5	if (!defined $node)
1751						{
1752						# create node object from the correct class
1753	3				10	$node = $class->new($node_name);
1754	3				7	$graph->add_node($node);
1755	3				5	$node->set_attributes($raw_attributes);
1756	3				6	$node->{autosplit_portname} = $idx; # some sensible default
1757						}
1758
1759						# apply the default attributes from the table
1760	3				7	$node->set_attributes($table_attr);
1761						# if found a global font attribute, override the font attribute with it
1762	3	50			6	$node->set_attribute('font',$font_face) if defined $font_face;
1763
1764						# parse the attributes and apply them to the node
1765	3				10	$self->_html_per_node( $self->_parse_html_attributes($attr_txt,$qr,'td'), $node );
1766
1767						# print STDERR "# Created $node_name\n";
1768
1769	3				6	$node->{autosplit_label} = $node_label;
1770	3				4	$node->{autosplit_basename} = $base_name;
1771
1772	3				3	push @rc, $node;
1773	3	100			11	if (@rc == 1)
1774						{
1775						# for correct as_txt output
1776	2				3	$node->{autosplit} = $org_label;
1777	2				8	$node->{autosplit} =~ s/\s+\z//; # strip trailing spaces
1778	2				6	$node->{autosplit} =~ s/^\s+//; # strip leading spaces
1779	2				2	$first_in_row = $node;
1780						}
1781						else
1782						{
1783						# second, third etc. get previous as origin
1784	1				2	my ($sx,$sy) = (1,0);
1785	1				2	my $origin = $rc[-2];
1786						# the first node in one row is relative to the first node in the
1787						# prev row
1788	1	50			4	if ($first == 1)
1789						{
1790	1				2	($sx,$sy) = (0,1); $origin = $first_in_row;
	1				2
1791	1				1	$first_in_row = $node;
1792	1				2	$first = 0;
1793						}
1794	1				4	$node->relative_to($origin,$sx,$sy);
1795						# suppress as_txt output for other parts
1796	1				1	$node->{autosplit} = undef;
1797						}
1798						# nec. for border-collapse
1799	3				8	$node->{autosplit_xy} = "$x,$y";
1800
1801	3				4	$idx++; # next node ID
1802	3				7	$x++;
1803						}
1804
1805						# next row
1806	3				6	$y++;
1807						}
1808
1809						# return created nodes
1810	2				8	@rc;
1811						}
1812
1813						#############################################################################
1814
1815						sub _parser_cleanup
1816						{
1817						# After initial parsing, do cleanup, e.g. autosplit nodes with shape record,
1818						# parse HTML-like labels, re-connect edges to the parts etc.
1819	102			102	99	my ($self) = @_;
1820
1821	102	50			149	print STDERR "# Parser cleanup pass\n" if $self->{debug};
1822
1823	102				90	my $g = $self->{_graph};
1824	102				218	my @nodes = $g->nodes();
1825
1826						# For all nodes that have a shape of "record", break down their label into
1827						# parts and create these as autosplit nodes.
1828						# For all nodes that have a label starting with "<", parse it as HTML.
1829
1830						# keep a record of all nodes to be deleted later:
1831	102				154	my $delete = {};
1832
1833	102				160	my $html_regexps = $self->_match_html_regexps();
1834	102				231	my $graph_flow = $g->attribute('flow');
1835	102				152	for my $n (@nodes)
1836						{
1837	259				482	my $label = $n->label(1);
1838						# we can get away with a direct lookup, since DOT does not have classes
1839	259		100		613	my $shape = $n->{att}->{shape} \|\| 'rect';
1840
1841	259	100	100		723	if ($shape ne 'record' && $label =~ /^<\s<.>\z/)
1842						{
1843	2	50			5	print STDERR "# HTML-like label found: $label\n" if $self->{debug};
1844	2				6	my @nodes = $self->_parse_html($n, $html_regexps);
1845						# remove the temp. and spurious node
1846	2				5	$delete->{$n->{name}} = undef;
1847	2				6	my @edges = $n->edges();
1848						# reconnect the found edges to the new autosplit parts
1849	2				3	for my $e (@edges)
1850						{
1851						# XXX TODO: connect to better suited parts based on flow?
1852	2	100			8	$e->start_at($nodes[0]) if ($e->{from} == $n);
1853	2	100			7	$e->end_at($nodes[0]) if ($e->{to} == $n);
1854						}
1855	2				7	$g->del_node($n);
1856	2				3	next;
1857						}
1858
1859	257	100	100		569	if ($shape eq 'record' && $label =~ /\\|/)
1860						{
1861	15				18	my $att = {};
1862						# create basename only when node name differes from label
1863	15				26	$att->{basename} = $n->{name};
1864	15	100			27	if ($n->{name} ne $label)
1865						{
1866	14				22	$att->{basename} = $n->{name};
1867						}
1868						# XXX TODO: autosplit needs to handle nesting like "{}".
1869
1870						# Replace "{ ... \| ... \| ... }" with "...\|\| ... \|\| ...." as a cheat
1871						# to fix some common cases
1872	15	100			32	if ($label =~ /^\s\{[^\{\}]+\}\s\z/)
1873						{
1874	2				8	$label =~ s/[\{\}]//g; # {..\|..} => ..\|..
1875						# if flow up/down: {A\|\|B} => "[ A\|\| \|\| B ]"
1876	2	100			9	$label =~ s/\\|/\\|\\| /g # ..\|.. => ..\|\| ..
1877						if ($graph_flow =~ /^(east\|west)/);
1878						# if flow left/right: {A\|\|B} => "[ A\| \|B ]"
1879	2	100			9	$label =~ s/\\|\\|/\\| \\|/g # ..\|.. => ..\| \|..
1880						if ($graph_flow =~ /^(north\|south)/);
1881						}
1882	15				49	my @rc = $self->_autosplit_node($g, $label, $att, 0 );
1883	15				39	my $group = $n->group();
1884	15				33	$n->del_attribute('label');
1885
1886	15				16	my $qr_clean = $self->{_qr_part_clean};
1887						# clean the base name of ports:
1888						# " test \| test" => "test\|test"
1889	15				161	$rc[0]->{autosplit} =~ s/(^\|\\|)$qr_clean/$1/g;
1890	15				52	$rc[0]->{att}->{basename} =~ s/(^\|\\|)$qr_clean/$1/g;
1891	15				41	$rc[0]->{autosplit} =~ s/^\s*//;
1892	15				33	$rc[0]->{att}->{basename} =~ s/^\s*//;
1893						# '\| \|' => '\| \|' to avoid empty parts via as_txt() => as_ascii()
1894	15				40	$rc[0]->{autosplit} =~ s/\\|\s\\|/\\| \\|/g;
1895	15				22	$rc[0]->{att}->{basename} =~ s/\\|\s\\|/\\| \\|/g;
1896	15				25	$rc[0]->{autosplit} =~ s/\\|\s\\|/\\| \\|/g;
1897	15				23	$rc[0]->{att}->{basename} =~ s/\\|\s\\|/\\| \\|/g;
1898	15	100			32	delete $rc[0]->{att}->{basename} if $rc[0]->{att}->{basename} eq $rc[0]->{autosplit};
1899
1900	15				18	for my $n1 (@rc)
1901						{
1902	45	50			58	$n1->add_to_group($group) if $group;
1903	45				66	$n1->set_attributes($n->{att});
1904						# remove the temp. "shape=record"
1905	45				62	$n1->del_attribute('shape');
1906						}
1907
1908						# If the helper node has edges, reconnect them to the first
1909						# part of the autosplit node (dot seems to render them arbitrarily
1910						# on the autosplit node):
1911
1912	15				50	for my $e (ord_values( $n->{edges} ))
1913						{
1914	0	0			0	$e->start_at($rc[0]) if $e->{from} == $n;
1915	0	0			0	$e->end_at($rc[0]) if $e->{to} == $n;
1916						}
1917						# remove the temp. and spurious node
1918	15				33	$delete->{$n->{name}} = undef;
1919	15				32	$g->del_node($n);
1920						}
1921						}
1922
1923						# During parsing, "bonn:f1" -> "berlin:f2" results in "bonn:f1" and
1924						# "berlin:f2" as nodes, plus an edge connecting them
1925
1926						# We find all of these nodes, move the edges to the freshly created
1927						# autosplit parts above, then delete the superflous temporary nodes.
1928
1929						# if we looked up "Bonn:f1", remember it here to save time:
1930	102				115	my $node_cache = {};
1931
1932	102				220	my @edges = $g->edges();
1933	102				200	@nodes = $g->nodes(); # get a fresh list of nodes after split
1934	102				183	for my $e (@edges)
1935						{
1936						# do this for both the "from" and "to" side of the edge:
1937	143				133	for my $side ('from','to')
1938						{
1939	286				253	my $n = $e->{$side};
1940	286	100			423	next unless defined $n->{_graphviz_portlet};
1941
1942	20				20	my $port = $n->{_graphviz_portlet};
1943	20				15	my $base = $n->{_graphviz_basename};
1944
1945	20				14	my $compass = '';
1946	20	100			37	if ($port =~ s/:(n\|ne\|e\|se\|s\|sw\|w\|nw)\z//)
1947						{
1948	1				1	$compass = $1;
1949						}
1950						# "Bonn:w" is port "w", and only "west" when that port doesn't exist
1951
1952						# look it up in the cache first
1953	20				35	my $node = $node_cache->{"$base:$port"};
1954
1955	20				13	my $p = undef;
1956	20	50			29	if (!defined $node)
1957						{
1958						# go through all nodes and for see if we find one with the right port name
1959	20				18	for my $na (@nodes)
1960						{
1961	326	100	66		518	next unless exists $na->{autosplit_portname} && exists $na->{autosplit_basename};
1962	206	100			256	next unless $na->{autosplit_basename} eq $base;
1963	62	100			78	next unless $na->{autosplit_portname} eq $port;
1964						# cache result
1965	19				33	$node_cache->{"$base:$port"} = $na;
1966	19				19	$node = $na;
1967	19	100			25	$p = $port_remap->{substr($compass,0,1)} if $compass; # ne => n => north
1968						}
1969						}
1970
1971	20	100			27	if (!defined $node)
1972						{
1973						# Still not defined?
1974						# port looks like a compass node?
1975	1	50			6	if ($port =~ /^(n\|ne\|e\|se\|s\|sw\|w\|nw)\z/)
1976						{
1977						# get the first node matching the base
1978	1				2	for my $na (@nodes)
1979						{
1980						#print STDERR "# evaluating $na ($na->{name} $na->{autosplit_basename}) ($base)\n";
1981	8	100			11	next unless exists $na->{autosplit_basename};
1982	4	100			7	next unless $na->{autosplit_basename} eq $base;
1983						# cache result
1984	2				4	$node_cache->{"$base:$port"} = $na;
1985	2				8	$node = $na;
1986						}
1987	1	50			3	if (!defined $node)
1988						{
1989	0				0	return $self->error("Cannot find autosplit node for $base:$port on edge $e->{id}");
1990						}
1991	1				4	$p = $port_remap->{substr($port,0,1)}; # ne => n => north
1992						}
1993						else
1994						{
1995						# uhoh...
1996	0				0	return $self->error("Cannot find autosplit node for $base:$port on edge $e->{id}");
1997						}
1998						}
1999
2000	20	100			24	if ($side eq 'from')
2001						{
2002	10				20	$delete->{$e->{from}->{name}} = undef;
2003	10	50			13	print STDERR "# Setting new edge start point to $node->{name}\n" if $self->{debug};
2004	10				21	$e->start_at($node);
2005	10	50	33		24	print STDERR "# Setting new edge end point to start at $p\n" if $self->{debug} && $p;
2006	10	100			21	$e->set_attribute('start', $p) if $p;
2007						}
2008						else
2009						{
2010	10				16	$delete->{$e->{to}->{name}} = undef;
2011	10	50			15	print STDERR "# Setting new edge end point to $node->{name}\n" if $self->{debug};
2012	10				20	$e->end_at($node);
2013	10	50	33		20	print STDERR "# Setting new edge end point to end at $p\n" if $self->{debug} && $p;
2014	10	100			23	$e->set_attribute('end', $p) if $p;
2015						}
2016
2017						} # end for side "from" and "to"
2018						# we have reconnected this edge
2019						}
2020
2021						# after reconnecting all edges, we can delete temp. nodes:
2022	102				101	for my $n (@nodes)
2023						{
2024	290	100			413	next unless exists $n->{_graphviz_portlet};
2025						# "c:w" => "c"
2026	21				15	my $name = $n->{name}; $name =~ s/:.*?\z//;
	21				73
2027						# add "c" unless we should delete the base node (this deletes record
2028						# and autosplit nodes, but keeps loners like "c:w" around as "c":
2029	21	100			40	$g->add_node($name) unless exists $delete->{$name};
2030						# delete "c:w"
2031	21				40	$g->del_node($n);
2032						}
2033
2034						# if the graph doesn't have a title, set the graph name as title
2035						$g->set_attribute('title', $self->{_graphviz_graph_name})
2036	102	50			232	unless defined $g->raw_attribute('title');
2037
2038						# cleanup if there are no groups
2039	102	100			196	if ($g->groups() == 0)
2040						{
2041	97				162	$g->del_attribute('group', 'align');
2042	97				138	$g->del_attribute('group', 'fill');
2043						}
2044	102				112	$g->{_warn_on_unknown_attributes} = 0; # reset to die again
2045
2046	102				653	$self;
2047						}
2048
2049						1;
2050						__END__