view release on metacpan or  search on metacpan

Graph.pm  view on Meta::CPAN

	my $self = bless {}, $class;

	# Edge callback.
	$self->{'callback_edge'} = sub {
		my ($self, $node, $link) = @_;
		$self->{'graph'}->add_edge($node->id, $link);
		return;
	};

	# Vertex callback.
	$self->{'callback_vertex'} = sub {
		my ($self, $node) = @_;
		$self->{'graph'}->add_vertex($node->id);
		return;
	};

	# Graph object.
	$self->{'graph'} = undef;

	# Map::Tube object.
	$self->{'tube'} = undef;

	# Process params.
	set_params($self, @params);

	# Check Map::Tube object.
	if (! defined $self->{'tube'}) {
		err "Parameter 'tube' is required.";
	}
	if (! defined &UNIVERSAL::DOES) {
		eval {
			require UNIVERSAL::DOES;
		};
		if ($EVAL_ERROR) {
			err 'Cannot load UNIVERSAL::DOES module.';
		}
	}
	if (! blessed($self->{'tube'})
		|| ! $self->{'tube'}->DOES('Map::Tube')) {

		err "Parameter 'tube' must be 'Map::Tube' object.";
	}

	# Graph object.
	if (! defined $self->{'graph'}) {
		$self->{'graph'} = Graph->new;
	}

	# Object.
	return $self;
}

# Get graph.
sub graph {
	my $self = shift;
	foreach my $node (values %{$self->{'tube'}->nodes}) {
		$self->{'callback_vertex'}->($self, $node);
	}
	my @processed;
	foreach my $node (values %{$self->{'tube'}->nodes}) {
		foreach my $link (split m/,/ms, $node->link) {
			if (none {
				($_->[0] eq $node->id && $_->[1] eq $link) 
				|| 
				($_->[0] eq $link && $_->[1] eq $node->id)
				} @processed) {

				$self->{'callback_edge'}->($self, $node, $link);
				push @processed, [$node->id, $link];
			}
		}
	}
	return $self->{'graph'};
}

1;

__END__

=encoding utf8

=head1 NAME

Map::Tube::Graph - Graph output for Map::Tube.

=head1 SYNOPSIS

 use Map::Tube::Graph;
 my $obj = Map::Tube::GraphViz->new(%params);
 my $graph = $obj->graph;

=head1 METHODS

=over 8

=item C<new(%params)>

 Constructor.

=over 8

=item * C<callback_edge>

 Edge callback.
 Default value is this:
 sub { 
         my ($self, $node, $link) = @_;
         $self->{'graph'}->add_edge($node->id, $link);
         return;
 }

=item * C<callback_vertex>

 Vertex callback.
 Default value is this:
 sub { 
         my ($self, $node) = @_;
         $self->{'graph'}->add_vertex($node->id);
         return;
 }