Algorithm-Dependency-Objects

 view release on metacpan or  search on metacpan

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

	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");
}

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

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){

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

sub unknown_object {
	my ( $self, $obj ) = @_;
	croak "$obj is not in the input objects";
}

sub schedule {
	my ( $self, @desired ) = @_;

	my $desired = Set::Object->new(@desired);

	my $selected = $self->selected;

	my $missing = $desired->difference($selected);

	$self->depends(@desired)->union($missing)->members;
}

sub schedule_all {
	my $self = shift;
	$self->objects->difference($self->selected)->members;
}

__PACKAGE__

__END__

=pod

=head1 NAME

Algorithm::Dependency::Objects - An implementation of an Object Dependency Algorithm

=head1 SYNOPSIS

	use Algorithm::Dependency::Objects;

	my $o = Algorithm::Dependency::Objects->new(
		objects => \@objects,
		selected => \@selected, # objects which are already taken care of
	);

	my @needed = $o->schedule( $objects[0] );

	# need to take care of @needed for $objecs[0] to be resolved

=head1 DESCRIPTION

This modules is a re-implementation of L<Algorithm::Dependency> using only
objects instead of object ids, making use of L<Set::Object> for book-keeping.

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

=head1 METHODS

=over 4

=item B<new>

Duh.

=item B<objects>

=item B<selected>

Returns the L<Set::Object> representing this collection. Objects is an
enumeration of all the object who we're dependo-frobnicating, and selected is
those that don't need to be run.

=item B<depends>

=item B<schedule>

=item B<schedule_all>

See L<Algorithm::Dependency>'s corresponding methods.

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

}

sub schedule_all {
	my ( $self, @args ) = @_;
	$self->_order($self->SUPER::schedule_all(@args));
}

sub _order {
	my ( $self, @queue ) = @_;

	my $selected = Set::Object->new( $self->selected->members );

	my $error_marker;
	my @schedule;

	my %dep_set; 

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

		if ( defined($error_marker) and refaddr($error_marker) == refaddr($obj) ) {
			$self->circular_dep($obj, @queue);
		}
		
		my $dep_set = $dep_set{refaddr $obj} ||= Set::Object->new( $self->get_deps($obj) );

		unless ( $selected->superset($dep_set) ) {
			# we have some missing deps
			# put the object back in the queue
			push @queue, $obj;

			# if we encounter it again without any change
			# then a circular dependency is detected
			$error_marker = $obj unless defined $error_marker;
		} else {
			# the dependancies are a subset of the selected objects,
			# so they are all resolved.
			push @schedule, $obj;

			# mark the object as selected
			$selected->insert($obj);

			# since something changed we can forget about the error marker
			undef $error_marker;
		}
	}

	# return the ordered list
	@schedule;
}

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

=head1 DESCRIPTION

=head1 METHODS

=over 4

=item B<new>

=item B<objects>

=item B<selected>

=item B<depends>

=item B<schedule>

=item B<schedule_all>

=item B<circular_dep>

=back

t/01_basics.t  view on Meta::CPAN

my $m;
BEGIN { use_ok($m = "Algorithm::Dependency::Objects") };

# Load the data/basics.txt file in as a source file, and test it rigorously.

{
	# Try to create a basic unordered dependency
	isa_ok(my $dep = $m->new(objects => $objs), $m);

	is($dep->objects->size, 6, "six objects are registered");
	is($dep->selected->size, 0, "no objects are selected");

	verify_dep_and_sched($dep, [
		[$a],		[],				[$a] 			], [
		[$b],		[$c],			[$b, $c] 		], [
		[$c],		[], 			[$c]			], [
		[$d],		[$e, $f],		[$d, $e, $f]	], [
		[$e],		[],				[$e]			], [
		[$f],		[],				[$f]			], [
		[$a, $b],	[$c],			[$a, $b, $c]	], [
		[$b, $d],	[$c, $e, $f],	[$b, $c, $d, $e, $f]		]
	);
}


{
	# Create with one selected
	isa_ok(my $dep = $m->new( objects => $objs, selected => Set::Object->new($f) ), $m);

	cmp_deeply(
		[ $dep->schedule_all ],
		bag( $a, $b, $c, $d, $e ),  # no $f
		"schedule_all",
	);

	is($dep->objects->size, 6, "six objects registered" );
	is($dep->selected->size, 1, "one objects selected" );

	ok( !$dep->selected->contains($a), "a is not selected" );
	ok( $dep->selected->contains($f), "f is selected" );

	verify_dep_and_sched($dep, [
		[$a],		[],				[$a] 			], [
		[$b],		[$c],			[$b, $c] 		], [
		[$c],		[], 			[$c]			], [
		[$d],		[$e],			[$d, $e]		], [
		[$e],		[],				[$e]			], [
		[$f],		[],				[]				], [
		[$a, $b],	[$c],			[$a, $b, $c]	], [
		[$b, $d],	[$c, $e],	[$b, $c, $d, $e]	]