view release on metacpan or  search on metacpan

script/dtd4  view on Meta::CPAN

			my $sub_brace_lit = $body[$i + 2];

			my $sub = _extract_subgraph($sub_name, $sub_brace_lit, $kind);
			push @subgraphs, $sub;

			# Skip id + brace literal; outer loop will move on.
			next;
		}

		# Edge: node_id, edge_id, node_id
		if ($nm eq 'edge_id') {
			my $edge_type = $t; # directed_edge / undirected_edge
			my $left      = $body[$i - 1];
			my $right     = $body[$i + 1];

			my $from = $left->{attributes}{name};
			my ($from_port, $from_compass) = _parse_port($left->{attributes}{port}, $left->{attributes}{value});

			my $to = $right->{attributes}{name};
			my ($to_port, $to_compass) = _parse_port($right->{attributes}{port}, $right->{attributes}{value});

			# Edge attributes may be in a bracket list attached to the right node_id.
			my %edge_attr;
			if ($right->{daughters} && @{ $right->{daughters} }) {
				for my $c (@{ $right->{daughters} }) {
					next unless ($c->{name} // '') eq 'attribute';
					my $ct  = $c->{attributes}{type} || $c->{attributes}{name};
					my $val = $c->{attributes}{value};
					$edge_attr{$ct} = $val;
				}
			}

			# Merge defaults into edge attrs.
			my $merged_attr = _merge_attrs(\%edge_defaults, \%edge_attr);

			my $edge = {
				from        => $from,
				from_port   => $from_port,
				from_compass=> $from_compass,
				to          => $to,
				to_port     => $to_port,
				to_compass  => $to_compass,
				attrs       => $merged_attr,
			};

			push @edges, $edge;

			# Ensure nodes exist in nodes hash (even if no explicit node block).
			$nodes{$from} ||= { attrs => {} };
			$nodes{$to}   ||= { attrs => {} };

			next;
		}

		# Node declaration: node_id with optional bracketed attributes.
		if ($nm eq 'node_id' && $t eq 'node_id') {
			my $node_name = $n->{attributes}{name};

			# If this node_id is part of an edge (immediately before/after edge_id),
			# we still want its attributes, but we don't treat it as a standalone node block.
			my $is_edge_endpoint = 0;
			if ($i + 1 < @body && ($body[$i + 1]{name} // '') eq 'edge_id') {
				$is_edge_endpoint = 1;
			}
			if ($i > 0 && ($body[$i - 1]{name} // '') eq 'edge_id') {
				$is_edge_endpoint = 1;
			}

			my %node_attr;
			if ($n->{daughters} && @{ $n->{daughters} }) {
				for my $c (@{ $n->{daughters} }) {
					next unless ($c->{name} // '') eq 'attribute';
					my $ct  = $c->{attributes}{type} || $c->{attributes}{name};
					my $val = $c->{attributes}{value};
					$node_attr{$ct} = $val;
				}
			}

			# Merge defaults into node attrs.
			my $merged_attr = _merge_attrs(\%node_defaults, \%node_attr);

			# Merge into existing node entry if present.
			if (exists $nodes{$node_name}) {
				$nodes{$node_name}{attrs} = _merge_attrs($nodes{$node_name}{attrs}, $merged_attr);
			}
			else {
				$nodes{$node_name} = { attrs => $merged_attr };
			}

			next;
		}
	}

	# Build adjacency (respecting kind: digraph vs graph).
	my $adjacency = _build_adjacency(\@edges, $kind);

	my $graph = {
		name          => $name,
		kind          => $kind,
		attrs         => \%attrs,
		node_defaults => \%node_defaults,
		edge_defaults => \%edge_defaults,
		nodes         => \%nodes,
		edges         => \@edges,
		subgraphs     => \@subgraphs,
		adjacency     => $adjacency,
	};

	return $graph;
}

sub _extract_subgraph {
	my ($name, $brace_lit, $kind) = @_;

	my @body = @{ $brace_lit->{daughters} || [] };

	my %attrs;
	my %node_defaults;
	my %edge_defaults;
	my %nodes;
	my @edges;
	my @subgraphs;

	for (my $i = 0; $i < @body; $i++) {
		my $n  = $body[$i];
		my $nm = $n->{name} // '';