File Coverage

blib/lib/Object/Dependency.pm

Criterion	Covered	Total	%
statement	128	188	68.0
branch	45	80	56.2
condition	33	89	37.0
subroutine	17	23	73.9
pod	10	15	66.6
total	233	395	58.9

package Object::Dependency;

use strict;
use warnings;
use Scalar::Util qw(refaddr blessed);
use Hash::Util qw(lock_keys);
use Carp qw(confess);
use List::MoreUtils qw(uniq);
use Data::Dumper;   # XXX

my $debug = 0;

our $VERSION = 0.41;

sub new
{
	my ($pkg, %more) = @_;
	my $self = {
		addrmap		=> {},	# maps object id to object for non-stuck objects
		independent	=> {},  # set of objects that have no dependencies
		stuck		=> {},  # maps object id to object for stuck objects
		%more,
	};
	bless $self, $pkg;
	lock_keys(%$self);
	return $self;
}

sub newitem
{
	my ($self, $i) = @_;
	my $addr = refaddr($i) || $i;
	my %item = (
		dg_addr		=> $addr,	# item number
		dg_item		=> $i,		# reference to object
		dg_depends	=> {},		# items this depends upon
		dg_blocks	=> {},		# items that depend upon this item
		dg_active	=> 0,		# item has been returned by independent() but not unlocked or removed
		dg_lock		=> 0,		# item is locked
		dg_desc		=> undef,	# description
		dg_stuck	=> undef,	# item is stuck, why it's stuck
	);
	return %item if wantarray;
	my $o = bless \%item, 'Object::Dependency::Item';
	lock_keys(%$o);
	return $o;
}

sub get_item
{
	my ($self, $addr) = @_;
	return $self->{addrmap}{$addr} || $self->{stuck}{$addr};
}

sub get_addr
{
	my ($self, $item) = @_;
	my $addr = refaddr($item) || $item;
	die unless $self->{addrmap}{$addr} || $self->{stuck}{$addr};
	return $addr;
}

sub unlock
{
	my ($self, $item) = @_;
	my $da = refaddr($item) || $item;
	my $dao = $self->{addrmap}{$da} || $self->{stuck}{$da} or confess;
	$dao->{dg_lock} = 0;
}

sub add
{
	my ($self, $item, @depends_upon) = @_;
	for my $i ($item, @depends_upon) {
		my $addr = refaddr($i) || $i;
		next if $self->{addrmap}{$addr};
		next if $self->{stuck}{$addr};
		$self->{addrmap}{$addr} = $self->newitem($i);
		$self->{independent}{$addr} = $self->{addrmap}{$addr};
		printf STDERR "ADD ITEM %s\n", $self->desc($addr) if $debug;
	};
	my $da = refaddr($item) || $item;
	my $dao = $self->{addrmap}{$da} || $self->{stuck}{$da};
	delete $self->{independent}{$da}
		if @depends_upon;
	for my $d (@depends_upon) {
		my $addr = refaddr($d) || $d;
		my $o = $self->{addrmap}{$addr} || $self->{stuck}{$addr};
		$o->{dg_blocks}{$da} = $dao;
		$dao->{dg_depends}{$addr} = $o;
		$self->stuck_dependency($da, "Stuck on " . $self->desc($o))
			if $self->{stuck}{$addr};
	}
}

sub remove_all_dependencies
{
	my ($self, @items) = @_;
	my (@remove);
	for my $i (@items) {
		my $addr = refaddr($i) || $i;
		my $o = $self->{addrmap}{$addr} || $self->{stuck}{$addr};
		for my $ubi (keys %{$o->{dg_blocks}}) {
			my $unblock = delete $o->{dg_blocks}{$ubi};
			delete $unblock->{dg_depends}{$addr};
			$self->remove_all_dependencies($unblock);
			push(@remove, $unblock);
			next if keys %{$unblock->{dg_depends}};
			next if $unblock->{dg_stuck};
			$self->{independent}{$unblock->{dg_addr}} = $unblock;
		}
	}
	$self->remove_dependency(grep { $self->{addrmap}{refaddr($_) || $_} || $self->{stuck}{refaddr($_) || $_} } uniq @remove);
}

sub is_dependency
{
	my ($self, $item) = @_;
	my $addr = refaddr($item) || $item;
	return defined($self->{addrmap}{$addr} || $self->{stuck}{$addr});
}

sub remove_dependency
{
	my ($self, @items) = @_;
	for my $i (@items) {
		my $addr = refaddr($i) || $i;
		if ($debug) {
			my($p,$f,$l) = caller;
			printf STDERR "REMOVE ITEM %s:%d: %s %s\n", $f, $l, $self->desc($addr), ($i->{desc} ? $i->{desc} : ($i->{trace} ? $i->{trace} : "$i"));
		}
		delete $self->{independent}{$addr};

		# we won't complain about removing stuck dependencies
		my $o = delete($self->{addrmap}{$addr}) || delete($self->{stuck}{$addr}) or confess;

		if (keys %{$o->{dg_depends}}) {
			printf STDERR "attempting to remove %s but it has dependencies that aren't met:\n", $self->desc($o);
			for my $da (keys %{$o->{dg_depends}}) {
				printf STDERR "\t%s\n", $self->desc($da);
			}
			die "fatal error";
		}
		for my $unblock (values %{$o->{dg_blocks}}) {
			delete $unblock->{dg_depends}{$addr};
			$unblock->{dg_active} = 0;
			next if keys %{$unblock->{dg_depends}};
			next if $unblock->{dg_stuck};
			$self->{independent}{$unblock->{dg_addr}} = $unblock;
		}
	}
}

sub stuck_dependency
{
	my ($self, $item, $problem) = @_;
	my $addr = refaddr($item) || $item;
	my $o = $self->{addrmap}{$addr} || $self->{stuck}{$addr};
	return if $o->{dg_stuck};
	confess unless blessed $o;
	$o->{dg_stuck} = $problem || sprintf("stuck called from %s line %d", (caller())[1,2]);
	$self->{stuck}{$addr} = $o;
	delete $self->{independent}{$addr};
	delete $self->{addrmap}{$addr};
	for my $also_stuck (keys %{$o->{dg_blocks}}) {
		$self->stuck_dependency($also_stuck, "Stuck on " . $self->desc($addr));
	}
}

sub independent
{
	my ($self, %opts) = @_;

	my $count = $opts{count} || 0;
	my $active = $opts{active} || 0;
	my $lock = $opts{lock} || 0;
	my $stuck = $opts{stuck} || 0;

	my @ind;
	for my $o (values %{$self->{$stuck ? 'stuck' : 'independent'}}) {
		next if $active && $o->{dg_active};
		next if $o->{dg_lock};
		push(@ind, $o->{dg_item});
		$o->{dg_active} = 1;
		$o->{dg_lock} = $lock;
		last if $count && @ind == $count;
	}
	return @ind if @ind;
	return () if keys %{$self->{independent}};
	return () unless keys %{$self->{addrmap}};
	confess "No independent objects, but there are still objects in the dependency graph:\n" . $self->dump_graph_string();
}

sub alldone
{
	my ($self) = @_;
	return 0 if keys %{$self->{independent}};
	return 0 if keys %{$self->{addrmap}};
	return 1;
}

sub desc
{
	my ($self, $addr, $desc) = @_;
	my $o;
	if (ref($addr)) {
		$o = $addr;
		$addr = refaddr($addr) || $addr;
	} else {
		$o = $self->{addrmap}{$addr} || $self->{stuck}{$addr};
	}
	return "NO SUCH OBJECT $addr" unless $o;
	my $node = $o->{dg_item};
	$o->{dg_desc} = $desc
		if defined $desc;
	$desc = '';
	$desc .= 'INDEPENDENT ' if $self->{independent}{$addr};
	$desc .= 'LOCKED ' if $o->{dg_lock};
	$desc .= 'ACTIVE ' if $o->{dg_lock};
	$desc .= "$addr ";
	if ($o->{dg_desc}) {
		$desc .= $o->{dg_desc};
	} elsif (blessed($node)) {
		if ($node->isa('Proc::JobQueue::Job')) {
			no warnings;
			$desc .= "JOB$node->{jobnum} $node->{status} $node->{desc}";
		} elsif ($node->isa('Proc::JobQueue::DependencyTask')) {
			$desc .= "TASK $node->{desc}";
		} else {
			die;
		}
	} else {
		$desc .= "???????????????????";
	}
	$desc .= " STUCK: $o->{dg_stuck}" if $o->{dg_stuck};
	return $desc;
}

sub dump_graph
{
	my ($self) = @_;
	print $self->dump_graph_string();
}

sub dump_graph_string
{
	my ($self) = @_;

	my $r = sprintf "Dependency Graph, alldone=%d\n", $self->alldone;
	my %desc;
	for my $addr (sort (keys %{$self->{addrmap}}, keys %{$self->{stuck}})) {
		$desc{$addr} = $self->desc($addr);
	}
	for my $addr (sort (keys %{$self->{addrmap}}, keys %{$self->{stuck}})) {
		$r .= "\t$desc{$addr}\n";
		my $node = $self->{addrmap}{$addr} || $self->{stuck}{$addr};
		for my $b (keys %{$node->{dg_blocks}}) {
			$r .= "\t\tBLOCKS\t$desc{$b}\n";
		}
		for my $d (keys %{$node->{dg_depends}}) {
			$r .= "\t\tDEP_ON\t$desc{$d}\n";
		}
	}
	return $r;
}

;

__END__