view release on metacpan or  search on metacpan

lib/Algorithm/Dependency/Objects.pm  view on Meta::CPAN

#!/usr/bin/perl

package Algorithm::Dependency::Objects;

use strict;
use warnings;

our $VERSION = '0.04';

use Scalar::Util qw/blessed/;
use Carp qw/croak/;

use Set::Object;

sub _to_set {
	my ( $class, $objects ) = @_;

	if ( ref $objects ) {
		$objects = Set::Object->new(@$objects) if not blessed $objects and ref $objects eq 'ARRAY';

		if ( blessed $objects and $objects->isa("Set::Object") ) {
			return $objects;
		}
	}

	return;
}

sub new {
	my ($class, %params) = @_;

	my $objects = $class->_to_set($params{objects}) or
		croak "The 'objects' parameter must be an array reference or a Set::Object";
	
	my $selected = exists($params{selected})
		? $class->_to_set($params{selected})
		: Set::Object->new()
			or croak "If provided, the 'selected' parameter must be an array reference or a Set::Object";
	
	# all the contents of the Set::Object must have depends methods
	$class->assert_can_get_deps($objects);

	$objects = $class->verify_input_set($objects);

	return bless {
		objects  => $objects,
		selected => $selected,
	}, $class;
}

sub objects  { (shift)->{objects}  }
sub selected { (shift)->{selected} }

sub get_deps {
	my ( $self, $obj ) = @_;
	$obj->depends;
}

sub can_get_deps {
	my ( $self, $obj ) = @_;
	$obj->can("depends");
}

sub assert_can_get_deps {
	my ( $self, $objs ) = @_;
	$self->can_get_deps($_) || croak "Objects must have a 'depends' method" for $objs->members;
}

sub depends {
	my ( $self, @objs ) = @_;

	my @queue = @objs;

	my $selected_now = Set::Object->new;
	my $selected_previously = $self->selected;

	my $all_objects = $self->objects;

	while (@queue){
		my $obj = shift @queue;

		$self->unknown_object($obj) unless $all_objects->contains($obj);

		next if $selected_now->contains($obj);
		next if $selected_previously->contains($obj);

		push @queue, $self->get_deps($obj);

		$selected_now->insert($obj);
	}

	$selected_now->remove(@objs);

	return wantarray ? $selected_now->members : $selected_now;
}

sub verify_input_set {
	my ( $self, $objects ) = @_;

	my $dependant = Set::Object->new(map { $self->get_deps($_) } $objects->members);

	my $unresolvable = $dependant->difference($objects);

	if ($unresolvable->size){
		return $self->handle_missing_objects($unresolvable, $objects);